OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [scanner.c] - Blame information for rev 856

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 285 jeremybenn
/* Character scanner.
2
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 3, 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 COPYING3.  If not see
20
<http://www.gnu.org/licenses/>.  */
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 "system.h"
46
#include "gfortran.h"
47
#include "toplev.h"
48
#include "debug.h"
49
#include "flags.h"
50
#include "cpp.h"
51
 
52
/* Structure for holding module and include file search path.  */
53
typedef struct gfc_directorylist
54
{
55
  char *path;
56
  bool use_for_modules;
57
  struct gfc_directorylist *next;
58
}
59
gfc_directorylist;
60
 
61
/* List of include file search directories.  */
62
static gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
63
 
64
static gfc_file *file_head, *current_file;
65
 
66
static int continue_flag, end_flag, openmp_flag, gcc_attribute_flag;
67
static int continue_count, continue_line;
68
static locus openmp_locus;
69
static locus gcc_attribute_locus;
70
 
71
gfc_source_form gfc_current_form;
72
static gfc_linebuf *line_head, *line_tail;
73
 
74
locus gfc_current_locus;
75
const char *gfc_source_file;
76
static FILE *gfc_src_file;
77
static gfc_char_t *gfc_src_preprocessor_lines[2];
78
 
79
extern int pedantic;
80
 
81
static struct gfc_file_change
82
{
83
  const char *filename;
84
  gfc_linebuf *lb;
85
  int line;
86
} *file_changes;
87
size_t file_changes_cur, file_changes_count;
88
size_t file_changes_allocated;
89
 
90
 
91
/* Functions dealing with our wide characters (gfc_char_t) and
92
   sequences of such characters.  */
93
 
94
int
95
gfc_wide_fits_in_byte (gfc_char_t c)
96
{
97
  return (c <= UCHAR_MAX);
98
}
99
 
100
static inline int
101
wide_is_ascii (gfc_char_t c)
102
{
103
  return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
104
}
105
 
106
int
107
gfc_wide_is_printable (gfc_char_t c)
108
{
109
  return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
110
}
111
 
112
gfc_char_t
113
gfc_wide_tolower (gfc_char_t c)
114
{
115
  return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
116
}
117
 
118
gfc_char_t
119
gfc_wide_toupper (gfc_char_t c)
120
{
121
  return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
122
}
123
 
124
int
125
gfc_wide_is_digit (gfc_char_t c)
126
{
127
  return (c >= '0' && c <= '9');
128
}
129
 
130
static inline int
131
wide_atoi (gfc_char_t *c)
132
{
133
#define MAX_DIGITS 20
134
  char buf[MAX_DIGITS+1];
135
  int i = 0;
136
 
137
  while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
138
    buf[i++] = *c++;
139
  buf[i] = '\0';
140
  return atoi (buf);
141
}
142
 
143
size_t
144
gfc_wide_strlen (const gfc_char_t *str)
145
{
146
  size_t i;
147
 
148
  for (i = 0; str[i]; i++)
149
    ;
150
 
151
  return i;
152
}
153
 
154
gfc_char_t *
155
gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
156
{
157
  size_t i;
158
 
159
  for (i = 0; i < len; i++)
160
    b[i] = c;
161
 
162
  return b;
163
}
164
 
165
static gfc_char_t *
166
wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
167
{
168
  gfc_char_t *d;
169
 
170
  for (d = dest; (*d = *src) != '\0'; ++src, ++d)
171
    ;
172
 
173
  return dest;
174
}
175
 
176
static gfc_char_t *
177
wide_strchr (const gfc_char_t *s, gfc_char_t c)
178
{
179
  do {
180
    if (*s == c)
181
      {
182
        return CONST_CAST(gfc_char_t *, s);
183
      }
184
  } while (*s++);
185
  return 0;
186
}
187
 
188
char *
189
gfc_widechar_to_char (const gfc_char_t *s, int length)
190
{
191
  size_t len, i;
192
  char *res;
193
 
194
  if (s == NULL)
195
    return NULL;
196
 
197
  /* Passing a negative length is used to indicate that length should be
198
     calculated using gfc_wide_strlen().  */
199
  len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
200
  res = XNEWVEC (char, len + 1);
201
 
202
  for (i = 0; i < len; i++)
203
    {
204
      gcc_assert (gfc_wide_fits_in_byte (s[i]));
205
      res[i] = (unsigned char) s[i];
206
    }
207
 
208
  res[len] = '\0';
209
  return res;
210
}
211
 
212
gfc_char_t *
213
gfc_char_to_widechar (const char *s)
214
{
215
  size_t len, i;
216
  gfc_char_t *res;
217
 
218
  if (s == NULL)
219
    return NULL;
220
 
221
  len = strlen (s);
222
  res = gfc_get_wide_string (len + 1);
223
 
224
  for (i = 0; i < len; i++)
225
    res[i] = (unsigned char) s[i];
226
 
227
  res[len] = '\0';
228
  return res;
229
}
230
 
231
static int
232
wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
233
{
234
  gfc_char_t c1, c2;
235
 
236
  while (n-- > 0)
237
    {
238
      c1 = *s1++;
239
      c2 = *s2++;
240
      if (c1 != c2)
241
        return (c1 > c2 ? 1 : -1);
242
      if (c1 == '\0')
243
        return 0;
244
    }
245
  return 0;
246
}
247
 
248
int
249
gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
250
{
251
  gfc_char_t c1, c2;
252
 
253
  while (n-- > 0)
254
    {
255
      c1 = gfc_wide_tolower (*s1++);
256
      c2 = TOLOWER (*s2++);
257
      if (c1 != c2)
258
        return (c1 > c2 ? 1 : -1);
259
      if (c1 == '\0')
260
        return 0;
261
    }
262
  return 0;
263
}
264
 
265
 
266
/* Main scanner initialization.  */
267
 
268
void
269
gfc_scanner_init_1 (void)
270
{
271
  file_head = NULL;
272
  line_head = NULL;
273
  line_tail = NULL;
274
 
275
  continue_count = 0;
276
  continue_line = 0;
277
 
278
  end_flag = 0;
279
}
280
 
281
 
282
/* Main scanner destructor.  */
283
 
284
void
285
gfc_scanner_done_1 (void)
286
{
287
  gfc_linebuf *lb;
288
  gfc_file *f;
289
 
290
  while(line_head != NULL)
291
    {
292
      lb = line_head->next;
293
      gfc_free(line_head);
294
      line_head = lb;
295
    }
296
 
297
  while(file_head != NULL)
298
    {
299
      f = file_head->next;
300
      gfc_free(file_head->filename);
301
      gfc_free(file_head);
302
      file_head = f;
303
    }
304
}
305
 
306
 
307
/* Adds path to the list pointed to by list.  */
308
 
309
static void
310
add_path_to_list (gfc_directorylist **list, const char *path,
311
                  bool use_for_modules, bool head)
312
{
313
  gfc_directorylist *dir;
314
  const char *p;
315
 
316
  p = path;
317
  while (*p == ' ' || *p == '\t')  /* someone might do "-I include" */
318
    if (*p++ == '\0')
319
      return;
320
 
321
  if (head || *list == NULL)
322
    {
323
      dir = XCNEW (gfc_directorylist);
324
      if (!head)
325
        *list = dir;
326
    }
327
  else
328
    {
329
      dir = *list;
330
      while (dir->next)
331
        dir = dir->next;
332
 
333
      dir->next = XCNEW (gfc_directorylist);
334
      dir = dir->next;
335
    }
336
 
337
  dir->next = head ? *list : NULL;
338
  if (head)
339
    *list = dir;
340
  dir->use_for_modules = use_for_modules;
341
  dir->path = XCNEWVEC (char, strlen (p) + 2);
342
  strcpy (dir->path, p);
343
  strcat (dir->path, "/");      /* make '/' last character */
344
}
345
 
346
 
347
void
348
gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir)
349
{
350
  add_path_to_list (&include_dirs, path, use_for_modules, file_dir);
351
 
352
  /* For '#include "..."' these directories are automatically searched.  */
353
  if (!file_dir)
354
    gfc_cpp_add_include_path (xstrdup(path), true);
355
}
356
 
357
 
358
void
359
gfc_add_intrinsic_modules_path (const char *path)
360
{
361
  add_path_to_list (&intrinsic_modules_dirs, path, true, false);
362
}
363
 
364
 
365
/* Release resources allocated for options.  */
366
 
367
void
368
gfc_release_include_path (void)
369
{
370
  gfc_directorylist *p;
371
 
372
  while (include_dirs != NULL)
373
    {
374
      p = include_dirs;
375
      include_dirs = include_dirs->next;
376
      gfc_free (p->path);
377
      gfc_free (p);
378
    }
379
 
380
  while (intrinsic_modules_dirs != NULL)
381
    {
382
      p = intrinsic_modules_dirs;
383
      intrinsic_modules_dirs = intrinsic_modules_dirs->next;
384
      gfc_free (p->path);
385
      gfc_free (p);
386
    }
387
 
388
  gfc_free (gfc_option.module_dir);
389
}
390
 
391
 
392
static FILE *
393 378 julius
open_included_file (const char *name, gfc_directorylist *list,
394
                    bool module, bool system)
395 285 jeremybenn
{
396
  char *fullname;
397
  gfc_directorylist *p;
398
  FILE *f;
399
 
400
  for (p = list; p; p = p->next)
401
    {
402
      if (module && !p->use_for_modules)
403
        continue;
404
 
405
      fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
406
      strcpy (fullname, p->path);
407
      strcat (fullname, name);
408
 
409
      f = gfc_open_file (fullname);
410
      if (f != NULL)
411 378 julius
        {
412
          if (gfc_cpp_makedep ())
413
            gfc_cpp_add_dep (fullname, system);
414
 
415
          return f;
416
        }
417 285 jeremybenn
    }
418
 
419
  return NULL;
420
}
421
 
422
 
423
/* Opens file for reading, searching through the include directories
424
   given if necessary.  If the include_cwd argument is true, we try
425
   to open the file in the current directory first.  */
426
 
427
FILE *
428
gfc_open_included_file (const char *name, bool include_cwd, bool module)
429
{
430 378 julius
  FILE *f = NULL;
431 285 jeremybenn
 
432 378 julius
  if (IS_ABSOLUTE_PATH (name) || include_cwd)
433 285 jeremybenn
    {
434
      f = gfc_open_file (name);
435 378 julius
      if (f && gfc_cpp_makedep ())
436
        gfc_cpp_add_dep (name, false);
437 285 jeremybenn
    }
438
 
439 378 julius
  if (!f)
440
    f = open_included_file (name, include_dirs, module, false);
441
 
442
  return f;
443 285 jeremybenn
}
444
 
445
FILE *
446
gfc_open_intrinsic_module (const char *name)
447
{
448 378 julius
  FILE *f = NULL;
449
 
450 285 jeremybenn
  if (IS_ABSOLUTE_PATH (name))
451 378 julius
    {
452
      f = gfc_open_file (name);
453
      if (f && gfc_cpp_makedep ())
454
        gfc_cpp_add_dep (name, true);
455
    }
456 285 jeremybenn
 
457 378 julius
  if (!f)
458
    f = open_included_file (name, intrinsic_modules_dirs, true, true);
459
 
460
  return f;
461 285 jeremybenn
}
462
 
463
 
464
/* Test to see if we're at the end of the main source file.  */
465
 
466
int
467
gfc_at_end (void)
468
{
469
  return end_flag;
470
}
471
 
472
 
473
/* Test to see if we're at the end of the current file.  */
474
 
475
int
476
gfc_at_eof (void)
477
{
478
  if (gfc_at_end ())
479
    return 1;
480
 
481
  if (line_head == NULL)
482
    return 1;                   /* Null file */
483
 
484
  if (gfc_current_locus.lb == NULL)
485
    return 1;
486
 
487
  return 0;
488
}
489
 
490
 
491
/* Test to see if we're at the beginning of a new line.  */
492
 
493
int
494
gfc_at_bol (void)
495
{
496
  if (gfc_at_eof ())
497
    return 1;
498
 
499
  return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
500
}
501
 
502
 
503
/* Test to see if we're at the end of a line.  */
504
 
505
int
506
gfc_at_eol (void)
507
{
508
  if (gfc_at_eof ())
509
    return 1;
510
 
511
  return (*gfc_current_locus.nextc == '\0');
512
}
513
 
514
static void
515
add_file_change (const char *filename, int line)
516
{
517
  if (file_changes_count == file_changes_allocated)
518
    {
519
      if (file_changes_allocated)
520
        file_changes_allocated *= 2;
521
      else
522
        file_changes_allocated = 16;
523
      file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
524
                                 file_changes_allocated);
525
    }
526
  file_changes[file_changes_count].filename = filename;
527
  file_changes[file_changes_count].lb = NULL;
528
  file_changes[file_changes_count++].line = line;
529
}
530
 
531
static void
532
report_file_change (gfc_linebuf *lb)
533
{
534
  size_t c = file_changes_cur;
535
  while (c < file_changes_count
536
         && file_changes[c].lb == lb)
537
    {
538
      if (file_changes[c].filename)
539
        (*debug_hooks->start_source_file) (file_changes[c].line,
540
                                           file_changes[c].filename);
541
      else
542
        (*debug_hooks->end_source_file) (file_changes[c].line);
543
      ++c;
544
    }
545
  file_changes_cur = c;
546
}
547
 
548
void
549
gfc_start_source_files (void)
550
{
551
  /* If the debugger wants the name of the main source file,
552
     we give it.  */
553
  if (debug_hooks->start_end_main_source_file)
554
    (*debug_hooks->start_source_file) (0, gfc_source_file);
555
 
556
  file_changes_cur = 0;
557
  report_file_change (gfc_current_locus.lb);
558
}
559
 
560
void
561
gfc_end_source_files (void)
562
{
563
  report_file_change (NULL);
564
 
565
  if (debug_hooks->start_end_main_source_file)
566
    (*debug_hooks->end_source_file) (0);
567
}
568
 
569
/* Advance the current line pointer to the next line.  */
570
 
571
void
572
gfc_advance_line (void)
573
{
574
  if (gfc_at_end ())
575
    return;
576
 
577
  if (gfc_current_locus.lb == NULL)
578
    {
579
      end_flag = 1;
580
      return;
581
    }
582
 
583
  if (gfc_current_locus.lb->next
584
      && !gfc_current_locus.lb->next->dbg_emitted)
585
    {
586
      report_file_change (gfc_current_locus.lb->next);
587
      gfc_current_locus.lb->next->dbg_emitted = true;
588
    }
589
 
590
  gfc_current_locus.lb = gfc_current_locus.lb->next;
591
 
592
  if (gfc_current_locus.lb != NULL)
593
    gfc_current_locus.nextc = gfc_current_locus.lb->line;
594
  else
595
    {
596
      gfc_current_locus.nextc = NULL;
597
      end_flag = 1;
598
    }
599
}
600
 
601
 
602
/* Get the next character from the input, advancing gfc_current_file's
603
   locus.  When we hit the end of the line or the end of the file, we
604
   start returning a '\n' in order to complete the current statement.
605
   No Fortran line conventions are implemented here.
606
 
607
   Requiring explicit advances to the next line prevents the parse
608
   pointer from being on the wrong line if the current statement ends
609
   prematurely.  */
610
 
611
static gfc_char_t
612
next_char (void)
613
{
614
  gfc_char_t c;
615
 
616
  if (gfc_current_locus.nextc == NULL)
617
    return '\n';
618
 
619
  c = *gfc_current_locus.nextc++;
620
  if (c == '\0')
621
    {
622
      gfc_current_locus.nextc--; /* Remain on this line.  */
623
      c = '\n';
624
    }
625
 
626
  return c;
627
}
628
 
629
 
630
/* Skip a comment.  When we come here the parse pointer is positioned
631
   immediately after the comment character.  If we ever implement
632
   compiler directives within comments, here is where we parse the
633
   directive.  */
634
 
635
static void
636
skip_comment_line (void)
637
{
638
  gfc_char_t c;
639
 
640
  do
641
    {
642
      c = next_char ();
643
    }
644
  while (c != '\n');
645
 
646
  gfc_advance_line ();
647
}
648
 
649
 
650
int
651
gfc_define_undef_line (void)
652
{
653
  char *tmp;
654
 
655
  /* All lines beginning with '#' are either #define or #undef.  */
656
  if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
657
    return 0;
658
 
659
  if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
660
    {
661
      tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
662
      (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
663
                              tmp);
664
      gfc_free (tmp);
665
    }
666
 
667
  if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
668
    {
669
      tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
670
      (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
671
                             tmp);
672
      gfc_free (tmp);
673
    }
674
 
675
  /* Skip the rest of the line.  */
676
  skip_comment_line ();
677
 
678
  return 1;
679
}
680
 
681
 
682
/* Return true if GCC$ was matched.  */
683
static bool
684
skip_gcc_attribute (locus start)
685
{
686
  bool r = false;
687
  char c;
688
  locus old_loc = gfc_current_locus;
689
 
690
  if ((c = next_char ()) == 'g' || c == 'G')
691
    if ((c = next_char ()) == 'c' || c == 'C')
692
      if ((c = next_char ()) == 'c' || c == 'C')
693
        if ((c = next_char ()) == '$')
694
          r = true;
695
 
696
  if (r == false)
697
    gfc_current_locus = old_loc;
698
  else
699
   {
700
      gcc_attribute_flag = 1;
701
      gcc_attribute_locus = old_loc;
702
      gfc_current_locus = start;
703
   }
704
 
705
  return r;
706
}
707
 
708
 
709
 
710
/* Comment lines are null lines, lines containing only blanks or lines
711
   on which the first nonblank line is a '!'.
712
   Return true if !$ openmp conditional compilation sentinel was
713
   seen.  */
714
 
715
static bool
716
skip_free_comments (void)
717
{
718
  locus start;
719
  gfc_char_t c;
720
  int at_bol;
721
 
722
  for (;;)
723
    {
724
      at_bol = gfc_at_bol ();
725
      start = gfc_current_locus;
726
      if (gfc_at_eof ())
727
        break;
728
 
729
      do
730
        c = next_char ();
731
      while (gfc_is_whitespace (c));
732
 
733
      if (c == '\n')
734
        {
735
          gfc_advance_line ();
736
          continue;
737
        }
738
 
739
      if (c == '!')
740
        {
741
          /* Keep the !GCC$ line.  */
742
                  if (at_bol && skip_gcc_attribute (start))
743
            return false;
744
 
745
          /* If -fopenmp, we need to handle here 2 things:
746
             1) don't treat !$omp as comments, but directives
747
             2) handle OpenMP conditional compilation, where
748
                !$ should be treated as 2 spaces (for initial lines
749
                only if followed by space).  */
750
          if (gfc_option.flag_openmp && at_bol)
751
            {
752
              locus old_loc = gfc_current_locus;
753
              if (next_char () == '$')
754
                {
755
                  c = next_char ();
756
                  if (c == 'o' || c == 'O')
757
                    {
758
                      if (((c = next_char ()) == 'm' || c == 'M')
759
                          && ((c = next_char ()) == 'p' || c == 'P'))
760
                        {
761
                          if ((c = next_char ()) == ' ' || c == '\t'
762
                              || continue_flag)
763
                            {
764
                              while (gfc_is_whitespace (c))
765
                                c = next_char ();
766
                              if (c != '\n' && c != '!')
767
                                {
768
                                  openmp_flag = 1;
769
                                  openmp_locus = old_loc;
770
                                  gfc_current_locus = start;
771
                                  return false;
772
                                }
773
                            }
774
                          else
775
                            gfc_warning_now ("!$OMP at %C starts a commented "
776
                                             "line as it neither is followed "
777
                                             "by a space nor is a "
778
                                             "continuation line");
779
                        }
780
                      gfc_current_locus = old_loc;
781
                      next_char ();
782
                      c = next_char ();
783
                    }
784
                  if (continue_flag || c == ' ' || c == '\t')
785
                    {
786
                      gfc_current_locus = old_loc;
787
                      next_char ();
788
                      openmp_flag = 0;
789
                      return true;
790
                    }
791
                }
792
              gfc_current_locus = old_loc;
793
            }
794
          skip_comment_line ();
795
          continue;
796
        }
797
 
798
      break;
799
    }
800
 
801
  if (openmp_flag && at_bol)
802
    openmp_flag = 0;
803
 
804
  gcc_attribute_flag = 0;
805
  gfc_current_locus = start;
806
  return false;
807
}
808
 
809
 
810
/* Skip comment lines in fixed source mode.  We have the same rules as
811
   in skip_free_comment(), except that we can have a 'c', 'C' or '*'
812
   in column 1, and a '!' cannot be in column 6.  Also, we deal with
813
   lines with 'd' or 'D' in column 1, if the user requested this.  */
814
 
815
static void
816
skip_fixed_comments (void)
817
{
818
  locus start;
819
  int col;
820
  gfc_char_t c;
821
 
822
  if (! gfc_at_bol ())
823
    {
824
      start = gfc_current_locus;
825
      if (! gfc_at_eof ())
826
        {
827
          do
828
            c = next_char ();
829
          while (gfc_is_whitespace (c));
830
 
831
          if (c == '\n')
832
            gfc_advance_line ();
833
          else if (c == '!')
834
            skip_comment_line ();
835
        }
836
 
837
      if (! gfc_at_bol ())
838
        {
839
          gfc_current_locus = start;
840
          return;
841
        }
842
    }
843
 
844
  for (;;)
845
    {
846
      start = gfc_current_locus;
847
      if (gfc_at_eof ())
848
        break;
849
 
850
      c = next_char ();
851
      if (c == '\n')
852
        {
853
          gfc_advance_line ();
854
          continue;
855
        }
856
 
857
      if (c == '!' || c == 'c' || c == 'C' || c == '*')
858
        {
859
          if (skip_gcc_attribute (start))
860
            {
861
              /* Canonicalize to *$omp.  */
862
              *start.nextc = '*';
863
              return;
864
            }
865
 
866
          /* If -fopenmp, we need to handle here 2 things:
867
             1) don't treat !$omp|c$omp|*$omp as comments, but directives
868
             2) handle OpenMP conditional compilation, where
869
                !$|c$|*$ should be treated as 2 spaces if the characters
870
                in columns 3 to 6 are valid fixed form label columns
871
                characters.  */
872
          if (gfc_current_locus.lb != NULL
873
              && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
874
            continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
875
 
876
          if (gfc_option.flag_openmp)
877
            {
878
              if (next_char () == '$')
879
                {
880
                  c = next_char ();
881
                  if (c == 'o' || c == 'O')
882
                    {
883
                      if (((c = next_char ()) == 'm' || c == 'M')
884
                          && ((c = next_char ()) == 'p' || c == 'P'))
885
                        {
886
                          c = next_char ();
887
                          if (c != '\n'
888
                              && ((openmp_flag && continue_flag)
889
                                  || c == ' ' || c == '\t' || c == '0'))
890
                            {
891
                              do
892
                                c = next_char ();
893
                              while (gfc_is_whitespace (c));
894
                              if (c != '\n' && c != '!')
895
                                {
896
                                  /* Canonicalize to *$omp.  */
897
                                  *start.nextc = '*';
898
                                  openmp_flag = 1;
899
                                  gfc_current_locus = start;
900
                                  return;
901
                                }
902
                            }
903
                        }
904
                    }
905
                  else
906
                    {
907
                      int digit_seen = 0;
908
 
909
                      for (col = 3; col < 6; col++, c = next_char ())
910
                        if (c == ' ')
911
                          continue;
912
                        else if (c == '\t')
913
                          {
914
                            col = 6;
915
                            break;
916
                          }
917
                        else if (c < '0' || c > '9')
918
                          break;
919
                        else
920
                          digit_seen = 1;
921
 
922
                      if (col == 6 && c != '\n'
923
                          && ((continue_flag && !digit_seen)
924
                              || c == ' ' || c == '\t' || c == '0'))
925
                        {
926
                          gfc_current_locus = start;
927
                          start.nextc[0] = ' ';
928
                          start.nextc[1] = ' ';
929
                          continue;
930
                        }
931
                    }
932
                }
933
              gfc_current_locus = start;
934
            }
935
          skip_comment_line ();
936
          continue;
937
        }
938
 
939
      if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
940
        {
941
          if (gfc_option.flag_d_lines == 0)
942
            {
943
              skip_comment_line ();
944
              continue;
945
            }
946
          else
947
            *start.nextc = c = ' ';
948
        }
949
 
950
      col = 1;
951
 
952
      while (gfc_is_whitespace (c))
953
        {
954
          c = next_char ();
955
          col++;
956
        }
957
 
958
      if (c == '\n')
959
        {
960
          gfc_advance_line ();
961
          continue;
962
        }
963
 
964
      if (col != 6 && c == '!')
965
        {
966
          if (gfc_current_locus.lb != NULL
967
              && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
968
            continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
969
          skip_comment_line ();
970
          continue;
971
        }
972
 
973
      break;
974
    }
975
 
976
  openmp_flag = 0;
977
  gcc_attribute_flag = 0;
978
  gfc_current_locus = start;
979
}
980
 
981
 
982
/* Skips the current line if it is a comment.  */
983
 
984
void
985
gfc_skip_comments (void)
986
{
987
  if (gfc_current_form == FORM_FREE)
988
    skip_free_comments ();
989
  else
990
    skip_fixed_comments ();
991
}
992
 
993
 
994
/* Get the next character from the input, taking continuation lines
995
   and end-of-line comments into account.  This implies that comment
996
   lines between continued lines must be eaten here.  For higher-level
997
   subroutines, this flattens continued lines into a single logical
998
   line.  The in_string flag denotes whether we're inside a character
999
   context or not.  */
1000
 
1001
gfc_char_t
1002
gfc_next_char_literal (int in_string)
1003
{
1004
  locus old_loc;
1005
  int i, prev_openmp_flag;
1006
  gfc_char_t c;
1007
 
1008
  continue_flag = 0;
1009
 
1010
restart:
1011
  c = next_char ();
1012
  if (gfc_at_end ())
1013
    {
1014
      continue_count = 0;
1015
      return c;
1016
    }
1017
 
1018
  if (gfc_current_form == FORM_FREE)
1019
    {
1020
      bool openmp_cond_flag;
1021
 
1022
      if (!in_string && c == '!')
1023
        {
1024
          if (gcc_attribute_flag
1025
              && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1026
                 sizeof (gfc_current_locus)) == 0)
1027
            goto done;
1028
 
1029
          if (openmp_flag
1030
              && memcmp (&gfc_current_locus, &openmp_locus,
1031
                 sizeof (gfc_current_locus)) == 0)
1032
            goto done;
1033
 
1034
          /* This line can't be continued */
1035
          do
1036
            {
1037
              c = next_char ();
1038
            }
1039
          while (c != '\n');
1040
 
1041
          /* Avoid truncation warnings for comment ending lines.  */
1042
          gfc_current_locus.lb->truncated = 0;
1043
 
1044
          goto done;
1045
        }
1046
 
1047
      if (c != '&')
1048
        goto done;
1049
 
1050
      /* If the next nonblank character is a ! or \n, we've got a
1051
         continuation line.  */
1052
      old_loc = gfc_current_locus;
1053
 
1054
      c = next_char ();
1055
      while (gfc_is_whitespace (c))
1056
        c = next_char ();
1057
 
1058
      /* Character constants to be continued cannot have commentary
1059
         after the '&'.  */
1060
 
1061
      if (in_string && c != '\n')
1062
        {
1063
          gfc_current_locus = old_loc;
1064
          c = '&';
1065
          goto done;
1066
        }
1067
 
1068
      if (c != '!' && c != '\n')
1069
        {
1070
          gfc_current_locus = old_loc;
1071
          c = '&';
1072
          goto done;
1073
        }
1074
 
1075
      prev_openmp_flag = openmp_flag;
1076
      continue_flag = 1;
1077
      if (c == '!')
1078
        skip_comment_line ();
1079
      else
1080
        gfc_advance_line ();
1081
 
1082
      if (gfc_at_eof())
1083
        goto not_continuation;
1084
 
1085
      /* We've got a continuation line.  If we are on the very next line after
1086
         the last continuation, increment the continuation line count and
1087
         check whether the limit has been exceeded.  */
1088
      if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1089
        {
1090
          if (++continue_count == gfc_option.max_continue_free)
1091
            {
1092
              if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1093
                gfc_warning ("Limit of %d continuations exceeded in "
1094
                             "statement at %C", gfc_option.max_continue_free);
1095
            }
1096
        }
1097
 
1098
      /* Check to see if the continuation line was truncated.  */
1099
      if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1100
          && gfc_current_locus.lb->truncated)
1101
        {
1102
          int maxlen = gfc_option.free_line_length;
1103
          gfc_current_locus.lb->truncated = 0;
1104
          gfc_current_locus.nextc += maxlen;
1105
          gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1106
          gfc_current_locus.nextc -= maxlen;
1107
        }
1108
 
1109
      /* Now find where it continues. First eat any comment lines.  */
1110
      openmp_cond_flag = skip_free_comments ();
1111
 
1112
      if (gfc_current_locus.lb != NULL
1113
          && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1114
        continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1115
 
1116
      if (prev_openmp_flag != openmp_flag)
1117
        {
1118
          gfc_current_locus = old_loc;
1119
          openmp_flag = prev_openmp_flag;
1120
          c = '&';
1121
          goto done;
1122
        }
1123
 
1124
      /* Now that we have a non-comment line, probe ahead for the
1125
         first non-whitespace character.  If it is another '&', then
1126
         reading starts at the next character, otherwise we must back
1127
         up to where the whitespace started and resume from there.  */
1128
 
1129
      old_loc = gfc_current_locus;
1130
 
1131
      c = next_char ();
1132
      while (gfc_is_whitespace (c))
1133
        c = next_char ();
1134
 
1135
      if (openmp_flag)
1136
        {
1137
          for (i = 0; i < 5; i++, c = next_char ())
1138
            {
1139
              gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1140
              if (i == 4)
1141
                old_loc = gfc_current_locus;
1142
            }
1143
          while (gfc_is_whitespace (c))
1144
            c = next_char ();
1145
        }
1146
 
1147
      if (c != '&')
1148
        {
1149
          if (in_string)
1150
            {
1151
              if (gfc_option.warn_ampersand)
1152
                gfc_warning_now ("Missing '&' in continued character "
1153
                                 "constant at %C");
1154
              gfc_current_locus.nextc--;
1155
            }
1156
          /* Both !$omp and !$ -fopenmp continuation lines have & on the
1157
             continuation line only optionally.  */
1158
          else if (openmp_flag || openmp_cond_flag)
1159
            gfc_current_locus.nextc--;
1160
          else
1161
            {
1162
              c = ' ';
1163
              gfc_current_locus = old_loc;
1164
              goto done;
1165
            }
1166
        }
1167
    }
1168
  else /* Fixed form.  */
1169
    {
1170
      /* Fixed form continuation.  */
1171
      if (!in_string && c == '!')
1172
        {
1173
          /* Skip comment at end of line.  */
1174
          do
1175
            {
1176
              c = next_char ();
1177
            }
1178
          while (c != '\n');
1179
 
1180
          /* Avoid truncation warnings for comment ending lines.  */
1181
          gfc_current_locus.lb->truncated = 0;
1182
        }
1183
 
1184
      if (c != '\n')
1185
        goto done;
1186
 
1187
      /* Check to see if the continuation line was truncated.  */
1188
      if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1189
          && gfc_current_locus.lb->truncated)
1190
        {
1191
          gfc_current_locus.lb->truncated = 0;
1192
          gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1193
        }
1194
 
1195
      prev_openmp_flag = openmp_flag;
1196
      continue_flag = 1;
1197
      old_loc = gfc_current_locus;
1198
 
1199
      gfc_advance_line ();
1200
      skip_fixed_comments ();
1201
 
1202
      /* See if this line is a continuation line.  */
1203
      if (openmp_flag != prev_openmp_flag)
1204
        {
1205
          openmp_flag = prev_openmp_flag;
1206
          goto not_continuation;
1207
        }
1208
 
1209
      if (!openmp_flag)
1210
        for (i = 0; i < 5; i++)
1211
          {
1212
            c = next_char ();
1213
            if (c != ' ')
1214
              goto not_continuation;
1215
          }
1216
      else
1217
        for (i = 0; i < 5; i++)
1218
          {
1219
            c = next_char ();
1220
            if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1221
              goto not_continuation;
1222
          }
1223
 
1224
      c = next_char ();
1225
      if (c == '0' || c == ' ' || c == '\n')
1226
        goto not_continuation;
1227
 
1228
      /* We've got a continuation line.  If we are on the very next line after
1229
         the last continuation, increment the continuation line count and
1230
         check whether the limit has been exceeded.  */
1231
      if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1232
        {
1233
          if (++continue_count == gfc_option.max_continue_fixed)
1234
            {
1235
              if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1236
                gfc_warning ("Limit of %d continuations exceeded in "
1237
                             "statement at %C",
1238
                             gfc_option.max_continue_fixed);
1239
            }
1240
        }
1241
 
1242
      if (gfc_current_locus.lb != NULL
1243
          && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1244
        continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1245
    }
1246
 
1247
  /* Ready to read first character of continuation line, which might
1248
     be another continuation line!  */
1249
  goto restart;
1250
 
1251
not_continuation:
1252
  c = '\n';
1253
  gfc_current_locus = old_loc;
1254
 
1255
done:
1256
  if (c == '\n')
1257
    continue_count = 0;
1258
  continue_flag = 0;
1259
  return c;
1260
}
1261
 
1262
 
1263
/* Get the next character of input, folded to lowercase.  In fixed
1264
   form mode, we also ignore spaces.  When matcher subroutines are
1265
   parsing character literals, they have to call
1266
   gfc_next_char_literal().  */
1267
 
1268
gfc_char_t
1269
gfc_next_char (void)
1270
{
1271
  gfc_char_t c;
1272
 
1273
  do
1274
    {
1275
      c = gfc_next_char_literal (0);
1276
    }
1277
  while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1278
 
1279
  return gfc_wide_tolower (c);
1280
}
1281
 
1282
char
1283
gfc_next_ascii_char (void)
1284
{
1285
  gfc_char_t c = gfc_next_char ();
1286
 
1287
  return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1288
                                    : (unsigned char) UCHAR_MAX);
1289
}
1290
 
1291
 
1292
gfc_char_t
1293
gfc_peek_char (void)
1294
{
1295
  locus old_loc;
1296
  gfc_char_t c;
1297
 
1298
  old_loc = gfc_current_locus;
1299
  c = gfc_next_char ();
1300
  gfc_current_locus = old_loc;
1301
 
1302
  return c;
1303
}
1304
 
1305
 
1306
char
1307
gfc_peek_ascii_char (void)
1308
{
1309
  gfc_char_t c = gfc_peek_char ();
1310
 
1311
  return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1312
                                    : (unsigned char) UCHAR_MAX);
1313
}
1314
 
1315
 
1316
/* Recover from an error.  We try to get past the current statement
1317
   and get lined up for the next.  The next statement follows a '\n'
1318
   or a ';'.  We also assume that we are not within a character
1319
   constant, and deal with finding a '\'' or '"'.  */
1320
 
1321
void
1322
gfc_error_recovery (void)
1323
{
1324
  gfc_char_t c, delim;
1325
 
1326
  if (gfc_at_eof ())
1327
    return;
1328
 
1329
  for (;;)
1330
    {
1331
      c = gfc_next_char ();
1332
      if (c == '\n' || c == ';')
1333
        break;
1334
 
1335
      if (c != '\'' && c != '"')
1336
        {
1337
          if (gfc_at_eof ())
1338
            break;
1339
          continue;
1340
        }
1341
      delim = c;
1342
 
1343
      for (;;)
1344
        {
1345
          c = next_char ();
1346
 
1347
          if (c == delim)
1348
            break;
1349
          if (c == '\n')
1350
            return;
1351
          if (c == '\\')
1352
            {
1353
              c = next_char ();
1354
              if (c == '\n')
1355
                return;
1356
            }
1357
        }
1358
      if (gfc_at_eof ())
1359
        break;
1360
    }
1361
}
1362
 
1363
 
1364
/* Read ahead until the next character to be read is not whitespace.  */
1365
 
1366
void
1367
gfc_gobble_whitespace (void)
1368
{
1369
  static int linenum = 0;
1370
  locus old_loc;
1371
  gfc_char_t c;
1372
 
1373
  do
1374
    {
1375
      old_loc = gfc_current_locus;
1376
      c = gfc_next_char_literal (0);
1377
      /* Issue a warning for nonconforming tabs.  We keep track of the line
1378
         number because the Fortran matchers will often back up and the same
1379
         line will be scanned multiple times.  */
1380
      if (!gfc_option.warn_tabs && c == '\t')
1381
        {
1382
          int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1383
          if (cur_linenum != linenum)
1384
            {
1385
              linenum = cur_linenum;
1386
              gfc_warning_now ("Nonconforming tab character at %C");
1387
            }
1388
        }
1389
    }
1390
  while (gfc_is_whitespace (c));
1391
 
1392
  gfc_current_locus = old_loc;
1393
}
1394
 
1395
 
1396
/* Load a single line into pbuf.
1397
 
1398
   If pbuf points to a NULL pointer, it is allocated.
1399
   We truncate lines that are too long, unless we're dealing with
1400
   preprocessor lines or if the option -ffixed-line-length-none is set,
1401
   in which case we reallocate the buffer to fit the entire line, if
1402
   need be.
1403
   In fixed mode, we expand a tab that occurs within the statement
1404
   label region to expand to spaces that leave the next character in
1405
   the source region.
1406
 
1407
   If first_char is not NULL, it's a pointer to a single char value holding
1408
   the first character of the line, which has already been read by the
1409
   caller.  This avoids the use of ungetc().
1410
 
1411
   load_line returns whether the line was truncated.
1412
 
1413
   NOTE: The error machinery isn't available at this point, so we can't
1414
         easily report line and column numbers consistent with other
1415
         parts of gfortran.  */
1416
 
1417
static int
1418
load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1419
{
1420
  static int linenum = 0, current_line = 1;
1421
  int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1422
  int trunc_flag = 0, seen_comment = 0;
1423
  int seen_printable = 0, seen_ampersand = 0;
1424
  gfc_char_t *buffer;
1425
  bool found_tab = false;
1426
 
1427
  /* Determine the maximum allowed line length.  */
1428
  if (gfc_current_form == FORM_FREE)
1429
    maxlen = gfc_option.free_line_length;
1430
  else if (gfc_current_form == FORM_FIXED)
1431
    maxlen = gfc_option.fixed_line_length;
1432
  else
1433
    maxlen = 72;
1434
 
1435
  if (*pbuf == NULL)
1436
    {
1437
      /* Allocate the line buffer, storing its length into buflen.
1438
         Note that if maxlen==0, indicating that arbitrary-length lines
1439
         are allowed, the buffer will be reallocated if this length is
1440
         insufficient; since 132 characters is the length of a standard
1441
         free-form line, we use that as a starting guess.  */
1442
      if (maxlen > 0)
1443
        buflen = maxlen;
1444
      else
1445
        buflen = 132;
1446
 
1447
      *pbuf = gfc_get_wide_string (buflen + 1);
1448
    }
1449
 
1450
  i = 0;
1451
  buffer = *pbuf;
1452
 
1453
  if (first_char)
1454
    c = *first_char;
1455
  else
1456
    c = getc (input);
1457
 
1458
  /* In order to not truncate preprocessor lines, we have to
1459
     remember that this is one.  */
1460
  preprocessor_flag = (c == '#' ? 1 : 0);
1461
 
1462
  for (;;)
1463
    {
1464
      if (c == EOF)
1465
        break;
1466
 
1467
      if (c == '\n')
1468
        {
1469
          /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1470
          if (gfc_current_form == FORM_FREE
1471
              && !seen_printable && seen_ampersand)
1472
            {
1473
              if (pedantic)
1474
                gfc_error_now ("'&' not allowed by itself in line %d",
1475
                               current_line);
1476
              else
1477
                gfc_warning_now ("'&' not allowed by itself in line %d",
1478
                                 current_line);
1479
            }
1480
          break;
1481
        }
1482
 
1483
      if (c == '\r' || c == '\0')
1484
        goto next_char;                 /* Gobble characters.  */
1485
 
1486
      if (c == '&')
1487
        {
1488
          if (seen_ampersand)
1489
            {
1490
              seen_ampersand = 0;
1491
              seen_printable = 1;
1492
            }
1493
          else
1494
            seen_ampersand = 1;
1495
        }
1496
 
1497
      if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1498
        seen_printable = 1;
1499
 
1500
      /* Is this a fixed-form comment?  */
1501
      if (gfc_current_form == FORM_FIXED && i == 0
1502
          && (c == '*' || c == 'c' || c == 'd'))
1503
        seen_comment = 1;
1504
 
1505
      /* Vendor extension: "<tab>1" marks a continuation line.  */
1506
      if (found_tab)
1507
        {
1508
          found_tab = false;
1509
          if (c >= '1' && c <= '9')
1510
            {
1511
              *(buffer-1) = c;
1512
              goto next_char;
1513
            }
1514
        }
1515
 
1516
      if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1517
        {
1518
          found_tab = true;
1519
 
1520
          if (!gfc_option.warn_tabs && seen_comment == 0
1521
              && current_line != linenum)
1522
            {
1523
              linenum = current_line;
1524
              gfc_warning_now ("Nonconforming tab character in column %d "
1525
                               "of line %d", i+1, linenum);
1526
            }
1527
 
1528
          while (i < 6)
1529
            {
1530
              *buffer++ = ' ';
1531
              i++;
1532
            }
1533
 
1534
          goto next_char;
1535
        }
1536
 
1537
      *buffer++ = c;
1538
      i++;
1539
 
1540
      if (maxlen == 0 || preprocessor_flag)
1541
        {
1542
          if (i >= buflen)
1543
            {
1544
              /* Reallocate line buffer to double size to hold the
1545
                overlong line.  */
1546
              buflen = buflen * 2;
1547
              *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1548
              buffer = (*pbuf) + i;
1549
            }
1550
        }
1551
      else if (i >= maxlen)
1552
        {
1553
          /* Truncate the rest of the line.  */
1554
          for (;;)
1555
            {
1556
              c = getc (input);
1557
              if (c == '\r')
1558
                continue;
1559
 
1560
              if (c == '\n' || c == EOF)
1561
                break;
1562
 
1563
              trunc_flag = 1;
1564
            }
1565
 
1566
          c = '\n';
1567
          continue;
1568
        }
1569
 
1570
next_char:
1571
      c = getc (input);
1572
    }
1573
 
1574
  /* Pad lines to the selected line length in fixed form.  */
1575
  if (gfc_current_form == FORM_FIXED
1576
      && gfc_option.fixed_line_length != 0
1577
      && !preprocessor_flag
1578
      && c != EOF)
1579
    {
1580
      while (i++ < maxlen)
1581
        *buffer++ = ' ';
1582
    }
1583
 
1584
  *buffer = '\0';
1585
  *pbuflen = buflen;
1586
  current_line++;
1587
 
1588
  return trunc_flag;
1589
}
1590
 
1591
 
1592
/* Get a gfc_file structure, initialize it and add it to
1593
   the file stack.  */
1594
 
1595
static gfc_file *
1596
get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1597
{
1598
  gfc_file *f;
1599
 
1600
  f = XCNEW (gfc_file);
1601
 
1602
  f->filename = xstrdup (name);
1603
 
1604
  f->next = file_head;
1605
  file_head = f;
1606
 
1607
  f->up = current_file;
1608
  if (current_file != NULL)
1609
    f->inclusion_line = current_file->line;
1610
 
1611
  linemap_add (line_table, reason, false, f->filename, 1);
1612
 
1613
  return f;
1614
}
1615
 
1616
 
1617
/* Deal with a line from the C preprocessor. The
1618
   initial octothorp has already been seen.  */
1619
 
1620
static void
1621
preprocessor_line (gfc_char_t *c)
1622
{
1623
  bool flag[5];
1624
  int i, line;
1625
  gfc_char_t *wide_filename;
1626
  gfc_file *f;
1627
  int escaped, unescape;
1628
  char *filename;
1629
 
1630
  c++;
1631
  while (*c == ' ' || *c == '\t')
1632
    c++;
1633
 
1634
  if (*c < '0' || *c > '9')
1635
    goto bad_cpp_line;
1636
 
1637
  line = wide_atoi (c);
1638
 
1639
  c = wide_strchr (c, ' ');
1640
  if (c == NULL)
1641
    {
1642
      /* No file name given.  Set new line number.  */
1643
      current_file->line = line;
1644
      return;
1645
    }
1646
 
1647
  /* Skip spaces.  */
1648
  while (*c == ' ' || *c == '\t')
1649
    c++;
1650
 
1651
  /* Skip quote.  */
1652
  if (*c != '"')
1653
    goto bad_cpp_line;
1654
  ++c;
1655
 
1656
  wide_filename = c;
1657
 
1658
  /* Make filename end at quote.  */
1659
  unescape = 0;
1660
  escaped = false;
1661
  while (*c && ! (!escaped && *c == '"'))
1662
    {
1663
      if (escaped)
1664
        escaped = false;
1665
      else if (*c == '\\')
1666
        {
1667
          escaped = true;
1668
          unescape++;
1669
        }
1670
      ++c;
1671
    }
1672
 
1673
  if (! *c)
1674
    /* Preprocessor line has no closing quote.  */
1675
    goto bad_cpp_line;
1676
 
1677
  *c++ = '\0';
1678
 
1679
  /* Undo effects of cpp_quote_string.  */
1680
  if (unescape)
1681
    {
1682
      gfc_char_t *s = wide_filename;
1683
      gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1684
 
1685
      wide_filename = d;
1686
      while (*s)
1687
        {
1688
          if (*s == '\\')
1689
            *d++ = *++s;
1690
          else
1691
            *d++ = *s;
1692
          s++;
1693
        }
1694
      *d = '\0';
1695
    }
1696
 
1697
  /* Get flags.  */
1698
 
1699
  flag[1] = flag[2] = flag[3] = flag[4] = false;
1700
 
1701
  for (;;)
1702
    {
1703
      c = wide_strchr (c, ' ');
1704
      if (c == NULL)
1705
        break;
1706
 
1707
      c++;
1708
      i = wide_atoi (c);
1709
 
1710
      if (1 <= i && i <= 4)
1711
        flag[i] = true;
1712
    }
1713
 
1714
  /* Convert the filename in wide characters into a filename in narrow
1715
     characters.  */
1716
  filename = gfc_widechar_to_char (wide_filename, -1);
1717
 
1718
  /* Interpret flags.  */
1719
 
1720
  if (flag[1]) /* Starting new file.  */
1721
    {
1722
      f = get_file (filename, LC_RENAME);
1723
      add_file_change (f->filename, f->inclusion_line);
1724
      current_file = f;
1725
    }
1726
 
1727
  if (flag[2]) /* Ending current file.  */
1728
    {
1729
      if (!current_file->up
1730
          || strcmp (current_file->up->filename, filename) != 0)
1731
        {
1732
          gfc_warning_now ("%s:%d: file %s left but not entered",
1733
                           current_file->filename, current_file->line,
1734
                           filename);
1735
          if (unescape)
1736
            gfc_free (wide_filename);
1737
          gfc_free (filename);
1738
          return;
1739
        }
1740
 
1741
      add_file_change (NULL, line);
1742
      current_file = current_file->up;
1743
      linemap_add (line_table, LC_RENAME, false, current_file->filename,
1744
                   current_file->line);
1745
    }
1746
 
1747
  /* The name of the file can be a temporary file produced by
1748
     cpp. Replace the name if it is different.  */
1749
 
1750
  if (strcmp (current_file->filename, filename) != 0)
1751
    {
1752
       /* FIXME: we leak the old filename because a pointer to it may be stored
1753
          in the linemap.  Alternative could be using GC or updating linemap to
1754
          point to the new name, but there is no API for that currently. */
1755
      current_file->filename = xstrdup (filename);
1756
    }
1757
 
1758
  /* Set new line number.  */
1759
  current_file->line = line;
1760
  if (unescape)
1761
    gfc_free (wide_filename);
1762
  gfc_free (filename);
1763
  return;
1764
 
1765
 bad_cpp_line:
1766
  gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1767
                   current_file->filename, current_file->line);
1768
  current_file->line++;
1769
}
1770
 
1771
 
1772
static gfc_try load_file (const char *, const char *, bool);
1773
 
1774
/* include_line()-- Checks a line buffer to see if it is an include
1775
   line.  If so, we call load_file() recursively to load the included
1776
   file.  We never return a syntax error because a statement like
1777
   "include = 5" is perfectly legal.  We return false if no include was
1778
   processed or true if we matched an include.  */
1779
 
1780
static bool
1781
include_line (gfc_char_t *line)
1782
{
1783
  gfc_char_t quote, *c, *begin, *stop;
1784
  char *filename;
1785
 
1786
  c = line;
1787
 
1788
  if (gfc_option.flag_openmp)
1789
    {
1790
      if (gfc_current_form == FORM_FREE)
1791
        {
1792
          while (*c == ' ' || *c == '\t')
1793
            c++;
1794
          if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1795
            c += 3;
1796
        }
1797
      else
1798
        {
1799
          if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1800
              && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1801
            c += 3;
1802
        }
1803
    }
1804
 
1805
  while (*c == ' ' || *c == '\t')
1806
    c++;
1807
 
1808
  if (gfc_wide_strncasecmp (c, "include", 7))
1809
    return false;
1810
 
1811
  c += 7;
1812
  while (*c == ' ' || *c == '\t')
1813
    c++;
1814
 
1815
  /* Find filename between quotes.  */
1816
 
1817
  quote = *c++;
1818
  if (quote != '"' && quote != '\'')
1819
    return false;
1820
 
1821
  begin = c;
1822
 
1823
  while (*c != quote && *c != '\0')
1824
    c++;
1825
 
1826
  if (*c == '\0')
1827
    return false;
1828
 
1829
  stop = c++;
1830
 
1831
  while (*c == ' ' || *c == '\t')
1832
    c++;
1833
 
1834
  if (*c != '\0' && *c != '!')
1835
    return false;
1836
 
1837
  /* We have an include line at this point.  */
1838
 
1839
  *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1840
                   read by anything else.  */
1841
 
1842
  filename = gfc_widechar_to_char (begin, -1);
1843
  load_file (filename, NULL, false);
1844
  gfc_free (filename);
1845
  return true;
1846
}
1847
 
1848
 
1849
/* Load a file into memory by calling load_line until the file ends.  */
1850
 
1851
static gfc_try
1852
load_file (const char *realfilename, const char *displayedname, bool initial)
1853
{
1854
  gfc_char_t *line;
1855
  gfc_linebuf *b;
1856
  gfc_file *f;
1857
  FILE *input;
1858
  int len, line_len;
1859
  bool first_line;
1860
  const char *filename;
1861
 
1862
  filename = displayedname ? displayedname : realfilename;
1863
 
1864
  for (f = current_file; f; f = f->up)
1865
    if (strcmp (filename, f->filename) == 0)
1866
      {
1867
        fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1868
                 "recursively\n", current_file->filename, current_file->line,
1869
                 filename);
1870
        return FAILURE;
1871
      }
1872
 
1873
  if (initial)
1874
    {
1875
      if (gfc_src_file)
1876
        {
1877
          input = gfc_src_file;
1878
          gfc_src_file = NULL;
1879
        }
1880
      else
1881
        input = gfc_open_file (realfilename);
1882
      if (input == NULL)
1883
        {
1884
          gfc_error_now ("Can't open file '%s'", filename);
1885
          return FAILURE;
1886
        }
1887
    }
1888
  else
1889
    {
1890
      input = gfc_open_included_file (realfilename, false, false);
1891
      if (input == NULL)
1892
        {
1893
          fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1894
                   current_file->filename, current_file->line, filename);
1895
          return FAILURE;
1896
        }
1897
    }
1898
 
1899
  /* Load the file.  */
1900
 
1901
  f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1902
  if (!initial)
1903
    add_file_change (f->filename, f->inclusion_line);
1904
  current_file = f;
1905
  current_file->line = 1;
1906
  line = NULL;
1907
  line_len = 0;
1908
  first_line = true;
1909
 
1910
  if (initial && gfc_src_preprocessor_lines[0])
1911
    {
1912
      preprocessor_line (gfc_src_preprocessor_lines[0]);
1913
      gfc_free (gfc_src_preprocessor_lines[0]);
1914
      gfc_src_preprocessor_lines[0] = NULL;
1915
      if (gfc_src_preprocessor_lines[1])
1916
        {
1917
          preprocessor_line (gfc_src_preprocessor_lines[1]);
1918
          gfc_free (gfc_src_preprocessor_lines[1]);
1919
          gfc_src_preprocessor_lines[1] = NULL;
1920
        }
1921
    }
1922
 
1923
  for (;;)
1924
    {
1925
      int trunc = load_line (input, &line, &line_len, NULL);
1926
 
1927
      len = gfc_wide_strlen (line);
1928
      if (feof (input) && len == 0)
1929
        break;
1930
 
1931
      /* If this is the first line of the file, it can contain a byte
1932
         order mark (BOM), which we will ignore:
1933
           FF FE is UTF-16 little endian,
1934
           FE FF is UTF-16 big endian,
1935
           EF BB BF is UTF-8.  */
1936
      if (first_line
1937
          && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1938
                             && line[1] == (unsigned char) '\xFE')
1939
              || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1940
                                && line[1] == (unsigned char) '\xFF')
1941
              || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1942
                                && line[1] == (unsigned char) '\xBB'
1943
                                && line[2] == (unsigned char) '\xBF')))
1944
        {
1945
          int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1946
          gfc_char_t *new_char = gfc_get_wide_string (line_len);
1947
 
1948
          wide_strcpy (new_char, &line[n]);
1949
          gfc_free (line);
1950
          line = new_char;
1951
          len -= n;
1952
        }
1953
 
1954
      /* There are three things this line can be: a line of Fortran
1955
         source, an include line or a C preprocessor directive.  */
1956
 
1957
      if (line[0] == '#')
1958
        {
1959
          /* When -g3 is specified, it's possible that we emit #define
1960
             and #undef lines, which we need to pass to the middle-end
1961
             so that it can emit correct debug info.  */
1962
          if (debug_info_level == DINFO_LEVEL_VERBOSE
1963
              && (wide_strncmp (line, "#define ", 8) == 0
1964
                  || wide_strncmp (line, "#undef ", 7) == 0))
1965
            ;
1966
          else
1967
            {
1968
              preprocessor_line (line);
1969
              continue;
1970
            }
1971
        }
1972
 
1973
      /* Preprocessed files have preprocessor lines added before the byte
1974
         order mark, so first_line is not about the first line of the file
1975
         but the first line that's not a preprocessor line.  */
1976
      first_line = false;
1977
 
1978
      if (include_line (line))
1979
        {
1980
          current_file->line++;
1981
          continue;
1982
        }
1983
 
1984
      /* Add line.  */
1985
 
1986
      b = (gfc_linebuf *) gfc_getmem (gfc_linebuf_header_size
1987
                                      + (len + 1) * sizeof (gfc_char_t));
1988
 
1989
      b->location
1990
        = linemap_line_start (line_table, current_file->line++, 120);
1991
      b->file = current_file;
1992
      b->truncated = trunc;
1993
      wide_strcpy (b->line, line);
1994
 
1995
      if (line_head == NULL)
1996
        line_head = b;
1997
      else
1998
        line_tail->next = b;
1999
 
2000
      line_tail = b;
2001
 
2002
      while (file_changes_cur < file_changes_count)
2003
        file_changes[file_changes_cur++].lb = b;
2004
    }
2005
 
2006
  /* Release the line buffer allocated in load_line.  */
2007
  gfc_free (line);
2008
 
2009
  fclose (input);
2010
 
2011
  if (!initial)
2012
    add_file_change (NULL, current_file->inclusion_line + 1);
2013
  current_file = current_file->up;
2014
  linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2015
  return SUCCESS;
2016
}
2017
 
2018
 
2019
/* Open a new file and start scanning from that file. Returns SUCCESS
2020
   if everything went OK, FAILURE otherwise.  If form == FORM_UNKNOWN
2021
   it tries to determine the source form from the filename, defaulting
2022
   to free form.  */
2023
 
2024
gfc_try
2025
gfc_new_file (void)
2026
{
2027
  gfc_try result;
2028
 
2029
  if (gfc_cpp_enabled ())
2030
    {
2031
      result = gfc_cpp_preprocess (gfc_source_file);
2032
      if (!gfc_cpp_preprocess_only ())
2033
        result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2034
    }
2035
  else
2036
    result = load_file (gfc_source_file, NULL, true);
2037
 
2038
  gfc_current_locus.lb = line_head;
2039
  gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2040
 
2041
#if 0 /* Debugging aid.  */
2042
  for (; line_head; line_head = line_head->next)
2043
    printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2044
            LOCATION_LINE (line_head->location), line_head->line);
2045
 
2046
  exit (0);
2047
#endif
2048
 
2049
  return result;
2050
}
2051
 
2052
static char *
2053
unescape_filename (const char *ptr)
2054
{
2055
  const char *p = ptr, *s;
2056
  char *d, *ret;
2057
  int escaped, unescape = 0;
2058
 
2059
  /* Make filename end at quote.  */
2060
  escaped = false;
2061
  while (*p && ! (! escaped && *p == '"'))
2062
    {
2063
      if (escaped)
2064
        escaped = false;
2065
      else if (*p == '\\')
2066
        {
2067
          escaped = true;
2068
          unescape++;
2069
        }
2070
      ++p;
2071
    }
2072
 
2073
  if (!*p || p[1])
2074
    return NULL;
2075
 
2076
  /* Undo effects of cpp_quote_string.  */
2077
  s = ptr;
2078
  d = XCNEWVEC (char, p + 1 - ptr - unescape);
2079
  ret = d;
2080
 
2081
  while (s != p)
2082
    {
2083
      if (*s == '\\')
2084
        *d++ = *++s;
2085
      else
2086
        *d++ = *s;
2087
      s++;
2088
    }
2089
  *d = '\0';
2090
  return ret;
2091
}
2092
 
2093
/* For preprocessed files, if the first tokens are of the form # NUM.
2094
   handle the directives so we know the original file name.  */
2095
 
2096
const char *
2097
gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2098
{
2099
  int c, len;
2100
  char *dirname, *tmp;
2101
 
2102
  gfc_src_file = gfc_open_file (filename);
2103
  if (gfc_src_file == NULL)
2104
    return NULL;
2105
 
2106
  c = getc (gfc_src_file);
2107
 
2108
  if (c != '#')
2109
    return NULL;
2110
 
2111
  len = 0;
2112
  load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2113
 
2114
  if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2115
    return NULL;
2116
 
2117
  tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2118
  filename = unescape_filename (tmp);
2119
  gfc_free (tmp);
2120
  if (filename == NULL)
2121
    return NULL;
2122
 
2123
  c = getc (gfc_src_file);
2124
 
2125
  if (c != '#')
2126
    return filename;
2127
 
2128
  len = 0;
2129
  load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2130
 
2131
  if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2132
    return filename;
2133
 
2134
  tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2135
  dirname = unescape_filename (tmp);
2136
  gfc_free (tmp);
2137
  if (dirname == NULL)
2138
    return filename;
2139
 
2140
  len = strlen (dirname);
2141
  if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2142
    {
2143
      gfc_free (dirname);
2144
      return filename;
2145
    }
2146
  dirname[len - 2] = '\0';
2147
  set_src_pwd (dirname);
2148
 
2149
  if (! IS_ABSOLUTE_PATH (filename))
2150
    {
2151
      char *p = XCNEWVEC (char, len + strlen (filename));
2152
 
2153
      memcpy (p, dirname, len - 2);
2154
      p[len - 2] = '/';
2155
      strcpy (p + len - 1, filename);
2156
      *canon_source_file = p;
2157
    }
2158
 
2159
  gfc_free (dirname);
2160
  return filename;
2161
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.