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           goto done;
 462         }
 463
 464       if (c != '&')
 465         goto done;
 466
 467       /* If the next nonblank character is a ! or \n, we've got a
 468          continuation line.  */
 469       old_loc = gfc_current_locus;
 470
 471       c = next_char ();
 472       while (gfc_is_whitespace (c))
 473         c = next_char ();
 474
 475       /* Character constants to be continued cannot have commentary
 476          after the '&'.  */
 477
 478       if (in_string && c != '\n')
 479         {
 480           gfc_current_locus = old_loc;
 481           c = '&';
 482           goto done;
 483         }
 484
 485       if (c != '!' && c != '\n')
 486         {
 487           gfc_current_locus = old_loc;
 488           c = '&';
 489           goto done;
 490         }
 491
 492       continue_flag = 1;
 493       if (c == '!')
 494         skip_comment_line ();
 495       else
 496         gfc_advance_line ();
 497
 498       /* We've got a continuation line and need to find where it continues.
 499          First eat any comment lines.  */
 500       gfc_skip_comments ();
 501
 502       /* Now that we have a non-comment line, probe ahead for the
 503          first non-whitespace character.  If it is another '&', then
 504          reading starts at the next character, otherwise we must back
 505          up to where the whitespace started and resume from there.  */
 506
 507       old_loc = gfc_current_locus;
 508
 509       c = next_char ();
 510       while (gfc_is_whitespace (c))
 511         c = next_char ();
 512
 513       if (c != '&')
 514         gfc_current_locus = old_loc;
 515
 516     }
 517   else
 518     {
 519       /* Fixed form continuation.  */
 520       if (!in_string && c == '!')
 521         {
 522           /* Skip comment at end of line.  */
 523           do
 524             {
 525               c = next_char ();
 526             }
 527           while (c != '\n');
 528         }
 529
 530       if (c != '\n')
 531         goto done;
 532
 533       continue_flag = 1;
 534       old_loc = gfc_current_locus;
 535
 536       gfc_advance_line ();
 537       gfc_skip_comments ();
 538
 539       /* See if this line is a continuation line.  */
 540       for (i = 0; i < 5; i++)
 541         {
 542           c = next_char ();
 543           if (c != ' ')
 544             goto not_continuation;
 545         }
 546
 547       c = next_char ();
 548       if (c == '0' || c == ' ')
 549         goto not_continuation;
 550     }
 551
 552   /* Ready to read first character of continuation line, which might
 553      be another continuation line!  */
 554   goto restart;
 555
 556 not_continuation:
 557   c = '\n';
 558   gfc_current_locus = old_loc;
 559
 560 done:
 561   continue_flag = 0;
 562   return c;
 563 }
 564
 565
 566 /* Get the next character of input, folded to lowercase.  In fixed
 567    form mode, we also ignore spaces.  When matcher subroutines are
 568    parsing character literals, they have to call
 569    gfc_next_char_literal().  */
 570
 571 int
 572 gfc_next_char (void)
 573 {
 574   int c;
 575
 576   do
 577     {
 578       c = gfc_next_char_literal (0);
 579     }
 580   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 581
 582   return TOLOWER (c);
 583 }
 584
 585
 586 int
 587 gfc_peek_char (void)
 588 {
 589   locus old_loc;
 590   int c;
 591
 592   old_loc = gfc_current_locus;
 593   c = gfc_next_char ();
 594   gfc_current_locus = old_loc;
 595
 596   return c;
 597 }
 598
 599
 600 /* Recover from an error.  We try to get past the current statement
 601    and get lined up for the next.  The next statement follows a '\n'
 602    or a ';'.  We also assume that we are not within a character
 603    constant, and deal with finding a '\'' or '"'.  */
 604
 605 void
 606 gfc_error_recovery (void)
 607 {
 608   char c, delim;
 609
 610   if (gfc_at_eof ())
 611     return;
 612
 613   for (;;)
 614     {
 615       c = gfc_next_char ();
 616       if (c == '\n' || c == ';')
 617         break;
 618
 619       if (c != '\'' && c != '"')
 620         {
 621           if (gfc_at_eof ())
 622             break;
 623           continue;
 624         }
 625       delim = c;
 626
 627       for (;;)
 628         {
 629           c = next_char ();
 630
 631           if (c == delim)
 632             break;
 633           if (c == '\n')
 634             goto done;
 635           if (c == '\\')
 636             {
 637               c = next_char ();
 638               if (c == '\n')
 639                 goto done;
 640             }
 641         }
 642       if (gfc_at_eof ())
 643         break;
 644     }
 645
 646 done:
 647   if (c == '\n')
 648     gfc_advance_line ();
 649 }
 650
 651
 652 /* Read ahead until the next character to be read is not whitespace.  */
 653
 654 void
 655 gfc_gobble_whitespace (void)
 656 {
 657   locus old_loc;
 658   int c;
 659
 660   do
 661     {
 662       old_loc = gfc_current_locus;
 663       c = gfc_next_char_literal (0);
 664     }
 665   while (gfc_is_whitespace (c));
 666
 667   gfc_current_locus = old_loc;
 668 }
 669
 670
 671 /* Load a single line into pbuf.
 672
 673    If pbuf points to a NULL pointer, it is allocated.
 674    We truncate lines that are too long, unless we're dealing with
 675    preprocessor lines or if the option -ffixed-line-length-none is set,
 676    in which case we reallocate the buffer to fit the entire line, if
 677    need be.
 678    In fixed mode, we expand a tab that occurs within the statement
 679    label region to expand to spaces that leave the next character in
 680    the source region.  */
 681
 682 static void
 683 load_line (FILE * input, char **pbuf, char *filename, int linenum)
 684 {
 685   int c, maxlen, i, trunc_flag, preprocessor_flag;
 686   static int buflen = 0;
 687   char *buffer;
 688
 689   /* Determine the maximum allowed line length.  */
 690   if (gfc_current_form == FORM_FREE)
 691     maxlen = GFC_MAX_LINE;
 692   else
 693     maxlen = gfc_option.fixed_line_length;
 694
 695   if (*pbuf == NULL)
 696     {
 697       /* Allocate the line buffer, storing its length into buflen.  */
 698       if (maxlen > 0)
 699         buflen = maxlen;
 700       else
 701         buflen = GFC_MAX_LINE;
 702
 703       *pbuf = gfc_getmem (buflen + 1);
 704     }
 705
 706   i = 0;
 707   buffer = *pbuf;
 708
 709   preprocessor_flag = 0;
 710   c = fgetc (input);
 711   if (c == '#')
 712     /* In order to not truncate preprocessor lines, we have to
 713        remember that this is one.  */
 714     preprocessor_flag = 1;
 715   ungetc (c, input);
 716
 717   for (;;)
 718     {
 719       c = fgetc (input);
 720
 721       if (c == EOF)
 722         break;
 723       if (c == '\n')
 724         break;
 725
 726       if (c == '\r')
 727         continue;               /* Gobble characters.  */
 728       if (c == '\0')
 729         continue;
 730
 731       if (c == '\032')
 732         {
 733           /* Ctrl-Z ends the file.  */
 734           while (fgetc (input) != EOF);
 735           break;
 736         }
 737
 738       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
 739         {                       /* Tab expansion.  */
 740           while (i <= 6)
 741             {
 742               *buffer++ = ' ';
 743               i++;
 744             }
 745
 746           continue;
 747         }
 748
 749       *buffer++ = c;
 750       i++;
 751
 752       if (i >= buflen && (maxlen == 0 || preprocessor_flag))
 753         {
 754           /* Reallocate line buffer to double size to hold the
 755              overlong line.  */
 756           buflen = buflen * 2;
 757           *pbuf = xrealloc (*pbuf, buflen);
 758           buffer = (*pbuf)+i;
 759         }
 760       else if (i >= buflen)
 761         {
 762           /* Truncate the rest of the line.  */
 763           trunc_flag = 1;
 764
 765           for (;;)
 766             {
 767               c = fgetc (input);
 768               if (c == '\n' || c == EOF)
 769                 break;
 770
 771               if (gfc_option.warn_line_truncation
 772                   && trunc_flag
 773                   && !gfc_is_whitespace (c))
 774                 {
 775                   gfc_warning_now ("%s:%d: Line is being truncated",
 776                                    filename, linenum);
 777                   trunc_flag = 0;
 778                 }
 779             }
 780
 781           ungetc ('\n', input);
 782         }
 783     }
 784
 785   /* Pad lines to the selected line length in fixed form.  */
 786   if (gfc_current_form == FORM_FIXED
 787       && gfc_option.fixed_line_length > 0
 788       && !preprocessor_flag
 789       && c != EOF)
 790     while (i++ < buflen)
 791       *buffer++ = ' ';
 792
 793   *buffer = '\0';
 794 }
 795
 796
 797 /* Get a gfc_file structure, initialize it and add it to
 798    the file stack.  */
 799
 800 static gfc_file *
 801 get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
 802 {
 803   gfc_file *f;
 804
 805   f = gfc_getmem (sizeof (gfc_file));
 806
 807   f->filename = gfc_getmem (strlen (name) + 1);
 808   strcpy (f->filename, name);
 809
 810   f->next = file_head;
 811   file_head = f;
 812
 813   f->included_by = current_file;
 814   if (current_file != NULL)
 815     f->inclusion_line = current_file->line;
 816
 817 #ifdef USE_MAPPED_LOCATION
 818   linemap_add (&line_table, reason, false, f->filename, 1);
 819 #endif
 820
 821   return f;
 822 }
 823
 824 /* Deal with a line from the C preprocessor. The
 825    initial octothorp has already been seen.  */
 826
 827 static void
 828 preprocessor_line (char *c)
 829 {
 830   bool flag[5];
 831   int i, line;
 832   char *filename;
 833   gfc_file *f;
 834   int escaped;
 835
 836   c++;
 837   while (*c == ' ' || *c == '\t')
 838     c++;
 839
 840   if (*c < '0' || *c > '9')
 841     goto bad_cpp_line;
 842
 843   line = atoi (c);
 844
 845   /* Set new line number.  */
 846   current_file->line = line;
 847
 848   c = strchr (c, ' ');
 849   if (c == NULL)
 850     /* No file name given.  */
 851     return;
 852
 853
 854
 855   /* Skip spaces.  */
 856   while (*c == ' ' || *c == '\t')
 857     c++;
 858
 859   /* Skip quote.  */
 860   if (*c != '"')
 861     goto bad_cpp_line;
 862   ++c;
 863
 864   filename = c;
 865
 866   /* Make filename end at quote.  */
 867   escaped = false;
 868   while (*c && ! (! escaped && *c == '"'))
 869     {
 870       if (escaped)
 871         escaped = false;
 872       else
 873         escaped = *c == '\\';
 874       ++c;
 875     }
 876
 877   if (! *c)
 878     /* Preprocessor line has no closing quote.  */
 879     goto bad_cpp_line;
 880
 881   *c++ = '\0';
 882
 883
 884
 885   /* Get flags.  */
 886
 887   flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
 888
 889   for (;;)
 890     {
 891       c = strchr (c, ' ');
 892       if (c == NULL)
 893         break;
 894
 895       c++;
 896       i = atoi (c);
 897
 898       if (1 <= i && i <= 4)
 899         flag[i] = true;
 900     }
 901
 902   /* Interpret flags.  */
 903
 904   if (flag[1] || flag[3]) /* Starting new file.  */
 905     {
 906       f = get_file (filename, LC_RENAME);
 907       f->up = current_file;
 908       current_file = f;
 909     }
 910
 911   if (flag[2]) /* Ending current file.  */
 912     {
 913       current_file = current_file->up;
 914     }
 915
 916   /* The name of the file can be a temporary file produced by
 917      cpp. Replace the name if it is different.  */
 918
 919   if (strcmp (current_file->filename, filename) != 0)
 920     {
 921       gfc_free (current_file->filename);
 922       current_file->filename = gfc_getmem (strlen (filename) + 1);
 923       strcpy (current_file->filename, filename);
 924     }
 925
 926   return;
 927
 928  bad_cpp_line:
 929   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
 930                    current_file->filename, current_file->line);
 931   current_file->line++;
 932 }
 933
 934
 935 static try load_file (char *, bool);
 936
 937 /* include_line()-- Checks a line buffer to see if it is an include
 938    line.  If so, we call load_file() recursively to load the included
 939    file.  We never return a syntax error because a statement like
 940    "include = 5" is perfectly legal.  We return false if no include was
 941    processed or true if we matched an include.  */
 942
 943 static bool
 944 include_line (char *line)
 945 {
 946   char quote, *c, *begin, *stop;
 947
 948   c = line;
 949   while (*c == ' ' || *c == '\t')
 950     c++;
 951
 952   if (strncasecmp (c, "include", 7))
 953       return false;
 954
 955   c += 7;
 956   while (*c == ' ' || *c == '\t')
 957     c++;
 958
 959   /* Find filename between quotes.  */
 960
 961   quote = *c++;
 962   if (quote != '"' && quote != '\'')
 963     return false;
 964
 965   begin = c;
 966
 967   while (*c != quote && *c != '\0')
 968     c++;
 969
 970   if (*c == '\0')
 971     return false;
 972
 973   stop = c++;
 974
 975   while (*c == ' ' || *c == '\t')
 976     c++;
 977
 978   if (*c != '\0' && *c != '!')
 979     return false;
 980
 981   /* We have an include line at this point.  */
 982
 983   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
 984                    read by anything else.  */
 985
 986   load_file (begin, false);
 987   return true;
 988 }
 989
 990 /* Load a file into memory by calling load_line until the file ends.  */
 991
 992 static try
 993 load_file (char *filename, bool initial)
 994 {
 995   char *line;
 996   gfc_linebuf *b;
 997   gfc_file *f;
 998   FILE *input;
 999   int len;
1000
1001   for (f = current_file; f; f = f->up)
1002     if (strcmp (filename, f->filename) == 0)
1003       {
1004         gfc_error_now ("File '%s' is being included recursively", filename);
1005         return FAILURE;
1006       }
1007
1008   if (initial)
1009     {
1010       input = gfc_open_file (filename);
1011       if (input == NULL)
1012         {
1013           gfc_error_now ("Can't open file '%s'", filename);
1014           return FAILURE;
1015         }
1016     }
1017   else
1018     {
1019       input = gfc_open_included_file (filename);
1020       if (input == NULL)
1021         {
1022           gfc_error_now ("Can't open included file '%s'", filename);
1023           return FAILURE;
1024         }
1025     }
1026
1027   /* Load the file.  */
1028
1029   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1030   f->up = current_file;
1031   current_file = f;
1032   current_file->line = 1;
1033   line = NULL;
1034
1035   for (;;)
1036     {
1037       load_line (input, &line, filename, current_file->line);
1038
1039       len = strlen (line);
1040       if (feof (input) && len == 0)
1041         break;
1042
1043       /* There are three things this line can be: a line of Fortran
1044          source, an include line or a C preprocessor directive.  */
1045
1046       if (line[0] == '#')
1047         {
1048           preprocessor_line (line);
1049           continue;
1050         }
1051
1052       if (include_line (line))
1053         {
1054           current_file->line++;
1055           continue;
1056         }
1057
1058       /* Add line.  */
1059
1060       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1061
1062 #ifdef USE_MAPPED_LOCATION
1063       b->location
1064         = linemap_line_start (&line_table, current_file->line++, 120);
1065 #else
1066       b->linenum = current_file->line++;
1067 #endif
1068       b->file = current_file;
1069       strcpy (b->line, line);
1070
1071       if (line_head == NULL)
1072         line_head = b;
1073       else
1074         line_tail->next = b;
1075
1076       line_tail = b;
1077     }
1078
1079   /* Release the line buffer allocated in load_line.  */
1080   gfc_free (line);
1081
1082   fclose (input);
1083
1084   current_file = current_file->up;
1085 #ifdef USE_MAPPED_LOCATION
1086   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1087 #endif
1088   return SUCCESS;
1089 }
1090
1091
1092 /* Determine the source form from the filename extension.  We assume
1093    case insensitivity.  */
1094
1095 static gfc_source_form
1096 form_from_filename (const char *filename)
1097 {
1098
1099   static const struct
1100   {
1101     const char *extension;
1102     gfc_source_form form;
1103   }
1104   exttype[] =
1105   {
1106     {
1107     ".f90", FORM_FREE}
1108     ,
1109     {
1110     ".f95", FORM_FREE}
1111     ,
1112     {
1113     ".f", FORM_FIXED}
1114     ,
1115     {
1116     ".for", FORM_FIXED}
1117     ,
1118     {
1119     "", FORM_UNKNOWN}
1120   };            /* sentinel value */
1121
1122   gfc_source_form f_form;
1123   const char *fileext;
1124   int i;
1125
1126   /* Find end of file name.  */
1127   i = 0;
1128   while ((i < PATH_MAX) && (filename[i] != '\0'))
1129     i++;
1130
1131   /* Improperly terminated or too-long filename.  */
1132   if (i == PATH_MAX)
1133     return FORM_UNKNOWN;
1134
1135   /* Find last period.  */
1136   while (i >= 0 && (filename[i] != '.'))
1137     i--;
1138
1139   /* Did we see a file extension?  */
1140   if (i < 0)
1141     return FORM_UNKNOWN; /* Nope  */
1142
1143   /* Get file extension and compare it to others.  */
1144   fileext = &(filename[i]);
1145
1146   i = -1;
1147   f_form = FORM_UNKNOWN;
1148   do
1149     {
1150       i++;
1151       if (strcasecmp (fileext, exttype[i].extension) == 0)
1152         {
1153           f_form = exttype[i].form;
1154           break;
1155         }
1156     }
1157   while (exttype[i].form != FORM_UNKNOWN);
1158
1159   return f_form;
1160 }
1161
1162
1163 /* Open a new file and start scanning from that file. Returns SUCCESS
1164    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1165    it tries to determine the source form from the filename, defaulting
1166    to free form.  */
1167
1168 try
1169 gfc_new_file (const char *filename, gfc_source_form form)
1170 {
1171   try result;
1172
1173   if (filename != NULL)
1174     {
1175       gfc_source_file = gfc_getmem (strlen (filename) + 1);
1176       strcpy (gfc_source_file, filename);
1177     }
1178   else
1179     gfc_source_file = NULL;
1180
1181   /* Decide which form the file will be read in as.  */
1182
1183   if (form != FORM_UNKNOWN)
1184     gfc_current_form = form;
1185   else
1186     {
1187       gfc_current_form = form_from_filename (filename);
1188
1189       if (gfc_current_form == FORM_UNKNOWN)
1190         {
1191           gfc_current_form = FORM_FREE;
1192           gfc_warning_now ("Reading file '%s' as free form.",
1193                            (filename[0] == '\0') ? "<stdin>" : filename);
1194         }
1195     }
1196
1197   result = load_file (gfc_source_file, true);
1198
1199   gfc_current_locus.lb = line_head;
1200   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1201
1202 #if 0 /* Debugging aid.  */
1203   for (; line_head; line_head = line_head->next)
1204     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1205 #ifdef USE_MAPPED_LOCATION
1206                 LOCATION_LINE (line_head->location),
1207 #else
1208                 line_head->linenum,
1209 #endif
1210                 line_head->line);
1211
1212   exit (0);
1213 #endif
1214
1215   return result;
1216 }