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