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
 838   c++;
 839   while (*c == ' ' || *c == '\t')
 840     c++;
 841
 842   if (*c < '0' || *c > '9')
 843     goto bad_cpp_line;
 844
 845   line = atoi (c);
 846
 847   c = strchr (c, ' ');
 848   if (c == NULL)
 849     /* Something we don't understand has happened.  */
 850     goto bad_cpp_line;
 851   c += 2;     /* Skip space and quote.  */
 852   filename = c;
 853
 854   c = strchr (c, '"'); /* Make filename end at quote.  */
 855   if (c == NULL)
 856     /* Preprocessor line has no closing quote.  */
 857     goto bad_cpp_line;
 858   *c++ = '\0';
 859
 860   /* Get flags.  */
 861
 862   flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
 863
 864   for (;;)
 865     {
 866       c = strchr (c, ' ');
 867       if (c == NULL)
 868         break;
 869
 870       c++;
 871       i = atoi (c);
 872
 873       if (1 <= i && i <= 4)
 874         flag[i] = true;
 875     }
 876
 877   /* Interpret flags.  */
 878
 879   if (flag[1] || flag[3]) /* Starting new file.  */
 880     {
 881       f = get_file (filename, LC_RENAME);
 882       f->up = current_file;
 883       current_file = f;
 884     }
 885
 886   if (flag[2]) /* Ending current file.  */
 887     {
 888       current_file = current_file->up;
 889     }
 890
 891   current_file->line = line;
 892
 893   /* The name of the file can be a temporary file produced by
 894      cpp. Replace the name if it is different.  */
 895
 896   if (strcmp (current_file->filename, filename) != 0)
 897     {
 898       gfc_free (current_file->filename);
 899       current_file->filename = gfc_getmem (strlen (filename) + 1);
 900       strcpy (current_file->filename, filename);
 901     }
 902
 903   return;
 904
 905  bad_cpp_line:
 906   gfc_warning_now ("%s:%d: Unknown preprocessor directive",
 907                    current_file->filename, current_file->line);
 908   current_file->line++;
 909 }
 910
 911
 912 static try load_file (char *, bool);
 913
 914 /* include_line()-- Checks a line buffer to see if it is an include
 915    line.  If so, we call load_file() recursively to load the included
 916    file.  We never return a syntax error because a statement like
 917    "include = 5" is perfectly legal.  We return false if no include was
 918    processed or true if we matched an include.  */
 919
 920 static bool
 921 include_line (char *line)
 922 {
 923   char quote, *c, *begin, *stop;
 924
 925   c = line;
 926   while (*c == ' ' || *c == '\t')
 927     c++;
 928
 929   if (strncasecmp (c, "include", 7))
 930       return false;
 931
 932   c += 7;
 933   while (*c == ' ' || *c == '\t')
 934     c++;
 935
 936   /* Find filename between quotes.  */
 937
 938   quote = *c++;
 939   if (quote != '"' && quote != '\'')
 940     return false;
 941
 942   begin = c;
 943
 944   while (*c != quote && *c != '\0')
 945     c++;
 946
 947   if (*c == '\0')
 948     return false;
 949
 950   stop = c++;
 951
 952   while (*c == ' ' || *c == '\t')
 953     c++;
 954
 955   if (*c != '\0' && *c != '!')
 956     return false;
 957
 958   /* We have an include line at this point. */
 959
 960   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
 961                    read by anything else.  */
 962
 963   load_file (begin, false);
 964   return true;
 965 }
 966
 967 /* Load a file into memory by calling load_line until the file ends.  */
 968
 969 static try
 970 load_file (char *filename, bool initial)
 971 {
 972   char *line;
 973   gfc_linebuf *b;
 974   gfc_file *f;
 975   FILE *input;
 976   int len;
 977
 978   for (f = current_file; f; f = f->up)
 979     if (strcmp (filename, f->filename) == 0)
 980       {
 981         gfc_error_now ("File '%s' is being included recursively", filename);
 982         return FAILURE;
 983       }
 984
 985   if (initial)
 986     {
 987       input = gfc_open_file (filename);
 988       if (input == NULL)
 989         {
 990           gfc_error_now ("Can't open file '%s'", filename);
 991           return FAILURE;
 992         }
 993     }
 994   else
 995     {
 996       input = gfc_open_included_file (filename);
 997       if (input == NULL)
 998         {
 999           gfc_error_now ("Can't open included file '%s'", filename);
1000           return FAILURE;
1001         }
1002     }
1003
1004   /* Load the file.  */
1005
1006   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1007   f->up = current_file;
1008   current_file = f;
1009   current_file->line = 1;
1010   line = NULL;
1011
1012   for (;;)
1013     {
1014       load_line (input, &line, filename, current_file->line);
1015
1016       len = strlen (line);
1017       if (feof (input) && len == 0)
1018         break;
1019
1020       /* There are three things this line can be: a line of Fortran
1021          source, an include line or a C preprocessor directive.  */
1022
1023       if (line[0] == '#')
1024         {
1025           preprocessor_line (line);
1026           continue;
1027         }
1028
1029       if (include_line (line))
1030         {
1031           current_file->line++;
1032           continue;
1033         }
1034
1035       /* Add line.  */
1036
1037       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1038
1039 #ifdef USE_MAPPED_LOCATION
1040       b->location
1041         = linemap_line_start (&line_table, current_file->line++, 120);
1042 #else
1043       b->linenum = current_file->line++;
1044 #endif
1045       b->file = current_file;
1046       strcpy (b->line, line);
1047
1048       if (line_head == NULL)
1049         line_head = b;
1050       else
1051         line_tail->next = b;
1052
1053       line_tail = b;
1054     }
1055
1056   /* Release the line buffer allocated in load_line.  */
1057   gfc_free (line);
1058
1059   fclose (input);
1060
1061   current_file = current_file->up;
1062 #ifdef USE_MAPPED_LOCATION
1063   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1064 #endif
1065   return SUCCESS;
1066 }
1067
1068
1069 /* Determine the source form from the filename extension.  We assume
1070    case insensitivity. */
1071
1072 static gfc_source_form
1073 form_from_filename (const char *filename)
1074 {
1075
1076   static const struct
1077   {
1078     const char *extension;
1079     gfc_source_form form;
1080   }
1081   exttype[] =
1082   {
1083     {
1084     ".f90", FORM_FREE}
1085     ,
1086     {
1087     ".f95", FORM_FREE}
1088     ,
1089     {
1090     ".f", FORM_FIXED}
1091     ,
1092     {
1093     ".for", FORM_FIXED}
1094     ,
1095     {
1096     "", FORM_UNKNOWN}
1097   };            /* sentinel value */
1098
1099   gfc_source_form f_form;
1100   const char *fileext;
1101   int i;
1102
1103   /* Find end of file name.  */
1104   i = 0;
1105   while ((i < PATH_MAX) && (filename[i] != '\0'))
1106     i++;
1107
1108   /* Improperly terminated or too-long filename.  */
1109   if (i == PATH_MAX)
1110     return FORM_UNKNOWN;
1111
1112   /* Find last period.  */
1113   while (i >= 0 && (filename[i] != '.'))
1114     i--;
1115
1116   /* Did we see a file extension?  */
1117   if (i < 0)
1118     return FORM_UNKNOWN; /* Nope  */
1119
1120   /* Get file extension and compare it to others.  */
1121   fileext = &(filename[i]);
1122
1123   i = -1;
1124   f_form = FORM_UNKNOWN;
1125   do
1126     {
1127       i++;
1128       if (strcasecmp (fileext, exttype[i].extension) == 0)
1129         {
1130           f_form = exttype[i].form;
1131           break;
1132         }
1133     }
1134   while (exttype[i].form != FORM_UNKNOWN);
1135
1136   return f_form;
1137 }
1138
1139
1140 /* Open a new file and start scanning from that file. Returns SUCCESS
1141    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1142    it tries to determine the source form from the filename, defaulting
1143    to free form.  */
1144
1145 try
1146 gfc_new_file (const char *filename, gfc_source_form form)
1147 {
1148   try result;
1149
1150   if (filename != NULL)
1151     {
1152       gfc_source_file = gfc_getmem (strlen (filename) + 1);
1153       strcpy (gfc_source_file, filename);
1154     }
1155   else
1156     gfc_source_file = NULL;
1157
1158   /* Decide which form the file will be read in as.  */
1159
1160   if (form != FORM_UNKNOWN)
1161     gfc_current_form = form;
1162   else
1163     {
1164       gfc_current_form = form_from_filename (filename);
1165
1166       if (gfc_current_form == FORM_UNKNOWN)
1167         {
1168           gfc_current_form = FORM_FREE;
1169           gfc_warning_now ("Reading file '%s' as free form.",
1170                            (filename[0] == '\0') ? "<stdin>" : filename);
1171         }
1172     }
1173
1174   result = load_file (gfc_source_file, true);
1175
1176   gfc_current_locus.lb = line_head;
1177   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1178
1179 #if 0 /* Debugging aid.  */
1180   for (; line_head; line_head = line_head->next)
1181     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1182 #ifdef USE_MAPPED_LOCATION
1183                 LOCATION_LINE (line_head->location),
1184 #else
1185                 line_head->linenum,
1186 #endif
1187                 line_head->line);
1188
1189   exit (0);
1190 #endif
1191
1192   return result;
1193 }