gcc/fortran/scanner.c

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