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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [parse.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
/* Main parser.
2
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3
   2009, 2010
4
   Free Software Foundation, Inc.
5
   Contributed by Andy Vaught
6
 
7
This file is part of GCC.
8
 
9
GCC is free software; you can redistribute it and/or modify it under
10
the terms of the GNU General Public License as published by the Free
11
Software Foundation; either version 3, or (at your option) any later
12
version.
13
 
14
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15
WARRANTY; without even the implied warranty of MERCHANTABILITY or
16
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17
for more details.
18
 
19
You should have received a copy of the GNU General Public License
20
along with GCC; see the file COPYING3.  If not see
21
<http://www.gnu.org/licenses/>.  */
22
 
23
#include "config.h"
24
#include "system.h"
25
#include <setjmp.h>
26
#include "gfortran.h"
27
#include "match.h"
28
#include "parse.h"
29
#include "debug.h"
30
 
31
/* Current statement label.  Zero means no statement label.  Because new_st
32
   can get wiped during statement matching, we have to keep it separate.  */
33
 
34
gfc_st_label *gfc_statement_label;
35
 
36
static locus label_locus;
37
static jmp_buf eof_buf;
38
 
39
gfc_state_data *gfc_state_stack;
40
 
41
/* TODO: Re-order functions to kill these forward decls.  */
42
static void check_statement_label (gfc_statement);
43
static void undo_new_statement (void);
44
static void reject_statement (void);
45
 
46
 
47
/* A sort of half-matching function.  We try to match the word on the
48
   input with the passed string.  If this succeeds, we call the
49
   keyword-dependent matching function that will match the rest of the
50
   statement.  For single keywords, the matching subroutine is
51
   gfc_match_eos().  */
52
 
53
static match
54
match_word (const char *str, match (*subr) (void), locus *old_locus)
55
{
56
  match m;
57
 
58
  if (str != NULL)
59
    {
60
      m = gfc_match (str);
61
      if (m != MATCH_YES)
62
        return m;
63
    }
64
 
65
  m = (*subr) ();
66
 
67
  if (m != MATCH_YES)
68
    {
69
      gfc_current_locus = *old_locus;
70
      reject_statement ();
71
    }
72
 
73
  return m;
74
}
75
 
76
 
77
/* Figure out what the next statement is, (mostly) regardless of
78
   proper ordering.  The do...while(0) is there to prevent if/else
79
   ambiguity.  */
80
 
81
#define match(keyword, subr, st)                                \
82
    do {                                                        \
83
      if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
84
        return st;                                              \
85
      else                                                      \
86
        undo_new_statement ();                            \
87
    } while (0);
88
 
89
 
90
/* This is a specialist version of decode_statement that is used
91
   for the specification statements in a function, whose
92
   characteristics are deferred into the specification statements.
93
   eg.:  INTEGER (king = mykind) foo ()
94
         USE mymodule, ONLY mykind.....
95
   The KIND parameter needs a return after USE or IMPORT, whereas
96
   derived type declarations can occur anywhere, up the executable
97
   block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
98
   out of the correct kind of specification statements.  */
99
static gfc_statement
100
decode_specification_statement (void)
101
{
102
  gfc_statement st;
103
  locus old_locus;
104
  char c;
105
 
106
  if (gfc_match_eos () == MATCH_YES)
107
    return ST_NONE;
108
 
109
  old_locus = gfc_current_locus;
110
 
111
  match ("import", gfc_match_import, ST_IMPORT);
112
  match ("use", gfc_match_use, ST_USE);
113
 
114
  if (gfc_current_block ()->result->ts.type != BT_DERIVED)
115
    goto end_of_block;
116
 
117
  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
118
  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
119
  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
120
 
121
  /* General statement matching: Instead of testing every possible
122
     statement, we eliminate most possibilities by peeking at the
123
     first character.  */
124
 
125
  c = gfc_peek_ascii_char ();
126
 
127
  switch (c)
128
    {
129
    case 'a':
130
      match ("abstract% interface", gfc_match_abstract_interface,
131
             ST_INTERFACE);
132
      match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
133
      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
134
      break;
135
 
136
    case 'b':
137
      match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
138
      break;
139
 
140
    case 'c':
141
      break;
142
 
143
    case 'd':
144
      match ("data", gfc_match_data, ST_DATA);
145
      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
146
      break;
147
 
148
    case 'e':
149
      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
150
      match ("entry% ", gfc_match_entry, ST_ENTRY);
151
      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
152
      match ("external", gfc_match_external, ST_ATTR_DECL);
153
      break;
154
 
155
    case 'f':
156
      match ("format", gfc_match_format, ST_FORMAT);
157
      break;
158
 
159
    case 'g':
160
      break;
161
 
162
    case 'i':
163
      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
164
      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
165
      match ("interface", gfc_match_interface, ST_INTERFACE);
166
      match ("intent", gfc_match_intent, ST_ATTR_DECL);
167
      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
168
      break;
169
 
170
    case 'm':
171
      break;
172
 
173
    case 'n':
174
      match ("namelist", gfc_match_namelist, ST_NAMELIST);
175
      break;
176
 
177
    case 'o':
178
      match ("optional", gfc_match_optional, ST_ATTR_DECL);
179
      break;
180
 
181
    case 'p':
182
      match ("parameter", gfc_match_parameter, ST_PARAMETER);
183
      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
184
      if (gfc_match_private (&st) == MATCH_YES)
185
        return st;
186
      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
187
      if (gfc_match_public (&st) == MATCH_YES)
188
        return st;
189
      match ("protected", gfc_match_protected, ST_ATTR_DECL);
190
      break;
191
 
192
    case 'r':
193
      break;
194
 
195
    case 's':
196
      match ("save", gfc_match_save, ST_ATTR_DECL);
197
      break;
198
 
199
    case 't':
200
      match ("target", gfc_match_target, ST_ATTR_DECL);
201
      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
202
      break;
203
 
204
    case 'u':
205
      break;
206
 
207
    case 'v':
208
      match ("value", gfc_match_value, ST_ATTR_DECL);
209
      match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
210
      break;
211
 
212
    case 'w':
213
      break;
214
    }
215
 
216
  /* This is not a specification statement.  See if any of the matchers
217
     has stored an error message of some sort.  */
218
 
219
end_of_block:
220
  gfc_clear_error ();
221
  gfc_buffer_error (0);
222
  gfc_current_locus = old_locus;
223
 
224
  return ST_GET_FCN_CHARACTERISTICS;
225
}
226
 
227
 
228
/* This is the primary 'decode_statement'.  */
229
static gfc_statement
230
decode_statement (void)
231
{
232
  gfc_statement st;
233
  locus old_locus;
234
  match m;
235
  char c;
236
 
237
#ifdef GFC_DEBUG
238
  gfc_symbol_state ();
239
#endif
240
 
241
  gfc_clear_error ();   /* Clear any pending errors.  */
242
  gfc_clear_warning (); /* Clear any pending warnings.  */
243
 
244
  gfc_matching_function = false;
245
 
246
  if (gfc_match_eos () == MATCH_YES)
247
    return ST_NONE;
248
 
249
  if (gfc_current_state () == COMP_FUNCTION
250
        && gfc_current_block ()->result->ts.kind == -1)
251
    return decode_specification_statement ();
252
 
253
  old_locus = gfc_current_locus;
254
 
255
  /* Try matching a data declaration or function declaration. The
256
      input "REALFUNCTIONA(N)" can mean several things in different
257
      contexts, so it (and its relatives) get special treatment.  */
258
 
259
  if (gfc_current_state () == COMP_NONE
260
      || gfc_current_state () == COMP_INTERFACE
261
      || gfc_current_state () == COMP_CONTAINS)
262
    {
263
      gfc_matching_function = true;
264
      m = gfc_match_function_decl ();
265
      if (m == MATCH_YES)
266
        return ST_FUNCTION;
267
      else if (m == MATCH_ERROR)
268
        reject_statement ();
269
      else
270
        gfc_undo_symbols ();
271
      gfc_current_locus = old_locus;
272
    }
273
  gfc_matching_function = false;
274
 
275
 
276
  /* Match statements whose error messages are meant to be overwritten
277
     by something better.  */
278
 
279
  match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
280
  match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
281
  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
282
 
283
  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
284
  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
285
 
286
  /* Try to match a subroutine statement, which has the same optional
287
     prefixes that functions can have.  */
288
 
289
  if (gfc_match_subroutine () == MATCH_YES)
290
    return ST_SUBROUTINE;
291
  gfc_undo_symbols ();
292
  gfc_current_locus = old_locus;
293
 
294
  /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
295
     might begin with a block label.  The match functions for these
296
     statements are unusual in that their keyword is not seen before
297
     the matcher is called.  */
298
 
299
  if (gfc_match_if (&st) == MATCH_YES)
300
    return st;
301
  gfc_undo_symbols ();
302
  gfc_current_locus = old_locus;
303
 
304
  if (gfc_match_where (&st) == MATCH_YES)
305
    return st;
306
  gfc_undo_symbols ();
307
  gfc_current_locus = old_locus;
308
 
309
  if (gfc_match_forall (&st) == MATCH_YES)
310
    return st;
311
  gfc_undo_symbols ();
312
  gfc_current_locus = old_locus;
313
 
314
  match (NULL, gfc_match_block, ST_BLOCK);
315
  match (NULL, gfc_match_do, ST_DO);
316
  match (NULL, gfc_match_select, ST_SELECT_CASE);
317
  match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
318
 
319
  /* General statement matching: Instead of testing every possible
320
     statement, we eliminate most possibilities by peeking at the
321
     first character.  */
322
 
323
  c = gfc_peek_ascii_char ();
324
 
325
  switch (c)
326
    {
327
    case 'a':
328
      match ("abstract% interface", gfc_match_abstract_interface,
329
             ST_INTERFACE);
330
      match ("allocate", gfc_match_allocate, ST_ALLOCATE);
331
      match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
332
      match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
333
      match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
334
      break;
335
 
336
    case 'b':
337
      match ("backspace", gfc_match_backspace, ST_BACKSPACE);
338
      match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
339
      match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
340
      break;
341
 
342
    case 'c':
343
      match ("call", gfc_match_call, ST_CALL);
344
      match ("close", gfc_match_close, ST_CLOSE);
345
      match ("continue", gfc_match_continue, ST_CONTINUE);
346
      match ("cycle", gfc_match_cycle, ST_CYCLE);
347
      match ("case", gfc_match_case, ST_CASE);
348
      match ("common", gfc_match_common, ST_COMMON);
349
      match ("contains", gfc_match_eos, ST_CONTAINS);
350
      match ("class", gfc_match_class_is, ST_CLASS_IS);
351
      break;
352
 
353
    case 'd':
354
      match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
355
      match ("data", gfc_match_data, ST_DATA);
356
      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
357
      break;
358
 
359
    case 'e':
360
      match ("end file", gfc_match_endfile, ST_END_FILE);
361
      match ("exit", gfc_match_exit, ST_EXIT);
362
      match ("else", gfc_match_else, ST_ELSE);
363
      match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
364
      match ("else if", gfc_match_elseif, ST_ELSEIF);
365
      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
366
 
367
      if (gfc_match_end (&st) == MATCH_YES)
368
        return st;
369
 
370
      match ("entry% ", gfc_match_entry, ST_ENTRY);
371
      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
372
      match ("external", gfc_match_external, ST_ATTR_DECL);
373
      break;
374
 
375
    case 'f':
376
      match ("final", gfc_match_final_decl, ST_FINAL);
377
      match ("flush", gfc_match_flush, ST_FLUSH);
378
      match ("format", gfc_match_format, ST_FORMAT);
379
      break;
380
 
381
    case 'g':
382
      match ("generic", gfc_match_generic, ST_GENERIC);
383
      match ("go to", gfc_match_goto, ST_GOTO);
384
      break;
385
 
386
    case 'i':
387
      match ("inquire", gfc_match_inquire, ST_INQUIRE);
388
      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
389
      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
390
      match ("import", gfc_match_import, ST_IMPORT);
391
      match ("interface", gfc_match_interface, ST_INTERFACE);
392
      match ("intent", gfc_match_intent, ST_ATTR_DECL);
393
      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
394
      break;
395
 
396
    case 'm':
397
      match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
398
      match ("module", gfc_match_module, ST_MODULE);
399
      break;
400
 
401
    case 'n':
402
      match ("nullify", gfc_match_nullify, ST_NULLIFY);
403
      match ("namelist", gfc_match_namelist, ST_NAMELIST);
404
      break;
405
 
406
    case 'o':
407
      match ("open", gfc_match_open, ST_OPEN);
408
      match ("optional", gfc_match_optional, ST_ATTR_DECL);
409
      break;
410
 
411
    case 'p':
412
      match ("print", gfc_match_print, ST_WRITE);
413
      match ("parameter", gfc_match_parameter, ST_PARAMETER);
414
      match ("pause", gfc_match_pause, ST_PAUSE);
415
      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
416
      if (gfc_match_private (&st) == MATCH_YES)
417
        return st;
418
      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
419
      match ("program", gfc_match_program, ST_PROGRAM);
420
      if (gfc_match_public (&st) == MATCH_YES)
421
        return st;
422
      match ("protected", gfc_match_protected, ST_ATTR_DECL);
423
      break;
424
 
425
    case 'r':
426
      match ("read", gfc_match_read, ST_READ);
427
      match ("return", gfc_match_return, ST_RETURN);
428
      match ("rewind", gfc_match_rewind, ST_REWIND);
429
      break;
430
 
431
    case 's':
432
      match ("sequence", gfc_match_eos, ST_SEQUENCE);
433
      match ("stop", gfc_match_stop, ST_STOP);
434
      match ("save", gfc_match_save, ST_ATTR_DECL);
435
      break;
436
 
437
    case 't':
438
      match ("target", gfc_match_target, ST_ATTR_DECL);
439
      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
440
      match ("type is", gfc_match_type_is, ST_TYPE_IS);
441
      break;
442
 
443
    case 'u':
444
      match ("use", gfc_match_use, ST_USE);
445
      break;
446
 
447
    case 'v':
448
      match ("value", gfc_match_value, ST_ATTR_DECL);
449
      match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
450
      break;
451
 
452
    case 'w':
453
      match ("wait", gfc_match_wait, ST_WAIT);
454
      match ("write", gfc_match_write, ST_WRITE);
455
      break;
456
    }
457
 
458
  /* All else has failed, so give up.  See if any of the matchers has
459
     stored an error message of some sort.  */
460
 
461
  if (gfc_error_check () == 0)
462
    gfc_error_now ("Unclassifiable statement at %C");
463
 
464
  reject_statement ();
465
 
466
  gfc_error_recovery ();
467
 
468
  return ST_NONE;
469
}
470
 
471
static gfc_statement
472
decode_omp_directive (void)
473
{
474
  locus old_locus;
475
  char c;
476
 
477
#ifdef GFC_DEBUG
478
  gfc_symbol_state ();
479
#endif
480
 
481
  gfc_clear_error ();   /* Clear any pending errors.  */
482
  gfc_clear_warning (); /* Clear any pending warnings.  */
483
 
484
  if (gfc_pure (NULL))
485
    {
486
      gfc_error_now ("OpenMP directives at %C may not appear in PURE "
487
                     "or ELEMENTAL procedures");
488
      gfc_error_recovery ();
489
      return ST_NONE;
490
    }
491
 
492
  old_locus = gfc_current_locus;
493
 
494
  /* General OpenMP directive matching: Instead of testing every possible
495
     statement, we eliminate most possibilities by peeking at the
496
     first character.  */
497
 
498
  c = gfc_peek_ascii_char ();
499
 
500
  switch (c)
501
    {
502
    case 'a':
503
      match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
504
      break;
505
    case 'b':
506
      match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
507
      break;
508
    case 'c':
509
      match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
510
      break;
511
    case 'd':
512
      match ("do", gfc_match_omp_do, ST_OMP_DO);
513
      break;
514
    case 'e':
515
      match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
516
      match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
517
      match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
518
      match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
519
      match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
520
      match ("end parallel sections", gfc_match_omp_eos,
521
             ST_OMP_END_PARALLEL_SECTIONS);
522
      match ("end parallel workshare", gfc_match_omp_eos,
523
             ST_OMP_END_PARALLEL_WORKSHARE);
524
      match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
525
      match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
526
      match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
527
      match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
528
      match ("end workshare", gfc_match_omp_end_nowait,
529
             ST_OMP_END_WORKSHARE);
530
      break;
531
    case 'f':
532
      match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
533
      break;
534
    case 'm':
535
      match ("master", gfc_match_omp_master, ST_OMP_MASTER);
536
      break;
537
    case 'o':
538
      match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
539
      break;
540
    case 'p':
541
      match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
542
      match ("parallel sections", gfc_match_omp_parallel_sections,
543
             ST_OMP_PARALLEL_SECTIONS);
544
      match ("parallel workshare", gfc_match_omp_parallel_workshare,
545
             ST_OMP_PARALLEL_WORKSHARE);
546
      match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
547
      break;
548
    case 's':
549
      match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
550
      match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
551
      match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
552
      break;
553
    case 't':
554
      match ("task", gfc_match_omp_task, ST_OMP_TASK);
555
      match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
556
      match ("threadprivate", gfc_match_omp_threadprivate,
557
             ST_OMP_THREADPRIVATE);
558
    case 'w':
559
      match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
560
      break;
561
    }
562
 
563
  /* All else has failed, so give up.  See if any of the matchers has
564
     stored an error message of some sort.  */
565
 
566
  if (gfc_error_check () == 0)
567
    gfc_error_now ("Unclassifiable OpenMP directive at %C");
568
 
569
  reject_statement ();
570
 
571
  gfc_error_recovery ();
572
 
573
  return ST_NONE;
574
}
575
 
576
static gfc_statement
577
decode_gcc_attribute (void)
578
{
579
  locus old_locus;
580
 
581
#ifdef GFC_DEBUG
582
  gfc_symbol_state ();
583
#endif
584
 
585
  gfc_clear_error ();   /* Clear any pending errors.  */
586
  gfc_clear_warning (); /* Clear any pending warnings.  */
587
  old_locus = gfc_current_locus;
588
 
589
  match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
590
 
591
  /* All else has failed, so give up.  See if any of the matchers has
592
     stored an error message of some sort.  */
593
 
594
  if (gfc_error_check () == 0)
595
    gfc_error_now ("Unclassifiable GCC directive at %C");
596
 
597
  reject_statement ();
598
 
599
  gfc_error_recovery ();
600
 
601
  return ST_NONE;
602
}
603
 
604
#undef match
605
 
606
 
607
/* Get the next statement in free form source.  */
608
 
609
static gfc_statement
610
next_free (void)
611
{
612
  match m;
613
  int i, cnt, at_bol;
614
  char c;
615
 
616
  at_bol = gfc_at_bol ();
617
  gfc_gobble_whitespace ();
618
 
619
  c = gfc_peek_ascii_char ();
620
 
621
  if (ISDIGIT (c))
622
    {
623
      char d;
624
 
625
      /* Found a statement label?  */
626
      m = gfc_match_st_label (&gfc_statement_label);
627
 
628
      d = gfc_peek_ascii_char ();
629
      if (m != MATCH_YES || !gfc_is_whitespace (d))
630
        {
631
          gfc_match_small_literal_int (&i, &cnt);
632
 
633
          if (cnt > 5)
634
            gfc_error_now ("Too many digits in statement label at %C");
635
 
636
          if (i == 0)
637
            gfc_error_now ("Zero is not a valid statement label at %C");
638
 
639
          do
640
            c = gfc_next_ascii_char ();
641
          while (ISDIGIT(c));
642
 
643
          if (!gfc_is_whitespace (c))
644
            gfc_error_now ("Non-numeric character in statement label at %C");
645
 
646
          return ST_NONE;
647
        }
648
      else
649
        {
650
          label_locus = gfc_current_locus;
651
 
652
          gfc_gobble_whitespace ();
653
 
654
          if (at_bol && gfc_peek_ascii_char () == ';')
655
            {
656
              gfc_error_now ("Semicolon at %C needs to be preceded by "
657
                             "statement");
658
              gfc_next_ascii_char (); /* Eat up the semicolon.  */
659
              return ST_NONE;
660
            }
661
 
662
          if (gfc_match_eos () == MATCH_YES)
663
            {
664
              gfc_warning_now ("Ignoring statement label in empty statement "
665
                               "at %L", &label_locus);
666
              gfc_free_st_label (gfc_statement_label);
667
              gfc_statement_label = NULL;
668
              return ST_NONE;
669
            }
670
        }
671
    }
672
  else if (c == '!')
673
    {
674
      /* Comments have already been skipped by the time we get here,
675
         except for GCC attributes and OpenMP directives.  */
676
 
677
      gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
678
      c = gfc_peek_ascii_char ();
679
 
680
      if (c == 'g')
681
        {
682
          int i;
683
 
684
          c = gfc_next_ascii_char ();
685
          for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
686
            gcc_assert (c == "gcc$"[i]);
687
 
688
          gfc_gobble_whitespace ();
689
          return decode_gcc_attribute ();
690
 
691
        }
692
      else if (c == '$' && gfc_option.flag_openmp)
693
        {
694
          int i;
695
 
696
          c = gfc_next_ascii_char ();
697
          for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
698
            gcc_assert (c == "$omp"[i]);
699
 
700
          gcc_assert (c == ' ' || c == '\t');
701
          gfc_gobble_whitespace ();
702
          return decode_omp_directive ();
703
        }
704
 
705
      gcc_unreachable ();
706
    }
707
 
708
  if (at_bol && c == ';')
709
    {
710
      gfc_error_now ("Semicolon at %C needs to be preceded by statement");
711
      gfc_next_ascii_char (); /* Eat up the semicolon.  */
712
      return ST_NONE;
713
    }
714
 
715
  return decode_statement ();
716
}
717
 
718
 
719
/* Get the next statement in fixed-form source.  */
720
 
721
static gfc_statement
722
next_fixed (void)
723
{
724
  int label, digit_flag, i;
725
  locus loc;
726
  gfc_char_t c;
727
 
728
  if (!gfc_at_bol ())
729
    return decode_statement ();
730
 
731
  /* Skip past the current label field, parsing a statement label if
732
     one is there.  This is a weird number parser, since the number is
733
     contained within five columns and can have any kind of embedded
734
     spaces.  We also check for characters that make the rest of the
735
     line a comment.  */
736
 
737
  label = 0;
738
  digit_flag = 0;
739
 
740
  for (i = 0; i < 5; i++)
741
    {
742
      c = gfc_next_char_literal (0);
743
 
744
      switch (c)
745
        {
746
        case ' ':
747
          break;
748
 
749
        case '0':
750
        case '1':
751
        case '2':
752
        case '3':
753
        case '4':
754
        case '5':
755
        case '6':
756
        case '7':
757
        case '8':
758
        case '9':
759
          label = label * 10 + ((unsigned char) c - '0');
760
          label_locus = gfc_current_locus;
761
          digit_flag = 1;
762
          break;
763
 
764
          /* Comments have already been skipped by the time we get
765
             here, except for GCC attributes and OpenMP directives.  */
766
 
767
        case '*':
768
          c = gfc_next_char_literal (0);
769
 
770
          if (TOLOWER (c) == 'g')
771
            {
772
              for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
773
                gcc_assert (TOLOWER (c) == "gcc$"[i]);
774
 
775
              return decode_gcc_attribute ();
776
            }
777
          else if (c == '$' && gfc_option.flag_openmp)
778
            {
779
              for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
780
                gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
781
 
782
              if (c != ' ' && c != '0')
783
                {
784
                  gfc_buffer_error (0);
785
                  gfc_error ("Bad continuation line at %C");
786
                  return ST_NONE;
787
                }
788
 
789
              return decode_omp_directive ();
790
            }
791
          /* FALLTHROUGH */
792
 
793
          /* Comments have already been skipped by the time we get
794
             here so don't bother checking for them.  */
795
 
796
        default:
797
          gfc_buffer_error (0);
798
          gfc_error ("Non-numeric character in statement label at %C");
799
          return ST_NONE;
800
        }
801
    }
802
 
803
  if (digit_flag)
804
    {
805
      if (label == 0)
806
        gfc_warning_now ("Zero is not a valid statement label at %C");
807
      else
808
        {
809
          /* We've found a valid statement label.  */
810
          gfc_statement_label = gfc_get_st_label (label);
811
        }
812
    }
813
 
814
  /* Since this line starts a statement, it cannot be a continuation
815
     of a previous statement.  If we see something here besides a
816
     space or zero, it must be a bad continuation line.  */
817
 
818
  c = gfc_next_char_literal (0);
819
  if (c == '\n')
820
    goto blank_line;
821
 
822
  if (c != ' ' && c != '0')
823
    {
824
      gfc_buffer_error (0);
825
      gfc_error ("Bad continuation line at %C");
826
      return ST_NONE;
827
    }
828
 
829
  /* Now that we've taken care of the statement label columns, we have
830
     to make sure that the first nonblank character is not a '!'.  If
831
     it is, the rest of the line is a comment.  */
832
 
833
  do
834
    {
835
      loc = gfc_current_locus;
836
      c = gfc_next_char_literal (0);
837
    }
838
  while (gfc_is_whitespace (c));
839
 
840
  if (c == '!')
841
    goto blank_line;
842
  gfc_current_locus = loc;
843
 
844
  if (c == ';')
845
    {
846
      gfc_error_now ("Semicolon at %C needs to be preceded by statement");
847
      return ST_NONE;
848
    }
849
 
850
  if (gfc_match_eos () == MATCH_YES)
851
    goto blank_line;
852
 
853
  /* At this point, we've got a nonblank statement to parse.  */
854
  return decode_statement ();
855
 
856
blank_line:
857
  if (digit_flag)
858
    gfc_warning_now ("Ignoring statement label in empty statement at %L",
859
                     &label_locus);
860
 
861
  gfc_current_locus.lb->truncated = 0;
862
  gfc_advance_line ();
863
  return ST_NONE;
864
}
865
 
866
 
867
/* Return the next non-ST_NONE statement to the caller.  We also worry
868
   about including files and the ends of include files at this stage.  */
869
 
870
static gfc_statement
871
next_statement (void)
872
{
873
  gfc_statement st;
874
  locus old_locus;
875
 
876
  gfc_new_block = NULL;
877
 
878
  gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
879 378 julius
  gfc_current_ns->old_equiv = gfc_current_ns->equiv;
880 285 jeremybenn
  for (;;)
881
    {
882
      gfc_statement_label = NULL;
883
      gfc_buffer_error (1);
884
 
885
      if (gfc_at_eol ())
886
        gfc_advance_line ();
887
 
888
      gfc_skip_comments ();
889
 
890
      if (gfc_at_end ())
891
        {
892
          st = ST_NONE;
893
          break;
894
        }
895
 
896
      if (gfc_define_undef_line ())
897
        continue;
898
 
899
      old_locus = gfc_current_locus;
900
 
901
      st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
902
 
903
      if (st != ST_NONE)
904
        break;
905
    }
906
 
907
  gfc_buffer_error (0);
908
 
909
  if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
910
    {
911
      gfc_free_st_label (gfc_statement_label);
912
      gfc_statement_label = NULL;
913
      gfc_current_locus = old_locus;
914
    }
915
 
916
  if (st != ST_NONE)
917
    check_statement_label (st);
918
 
919
  return st;
920
}
921
 
922
 
923
/****************************** Parser ***********************************/
924
 
925
/* The parser subroutines are of type 'try' that fail if the file ends
926
   unexpectedly.  */
927
 
928
/* Macros that expand to case-labels for various classes of
929
   statements.  Start with executable statements that directly do
930
   things.  */
931
 
932
#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
933
  case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
934
  case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
935
  case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
936
  case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
937
  case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
938
  case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
939
  case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
940
  case ST_OMP_BARRIER: case ST_OMP_TASKWAIT
941
 
942
/* Statements that mark other executable statements.  */
943
 
944
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
945
  case ST_IF_BLOCK: case ST_BLOCK: \
946
  case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
947
  case ST_OMP_PARALLEL: \
948
  case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
949
  case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
950
  case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
951
  case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
952
  case ST_OMP_TASK
953
 
954
/* Declaration statements */
955
 
956
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
957
  case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
958
  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
959
  case ST_PROCEDURE
960
 
961
/* Block end statements.  Errors associated with interchanging these
962
   are detected in gfc_match_end().  */
963
 
964
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
965
                 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
966
                 case ST_END_BLOCK
967
 
968
 
969
/* Push a new state onto the stack.  */
970
 
971
static void
972
push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
973
{
974
  p->state = new_state;
975
  p->previous = gfc_state_stack;
976
  p->sym = sym;
977
  p->head = p->tail = NULL;
978
  p->do_variable = NULL;
979
  gfc_state_stack = p;
980
}
981
 
982
 
983
/* Pop the current state.  */
984
static void
985
pop_state (void)
986
{
987
  gfc_state_stack = gfc_state_stack->previous;
988
}
989
 
990
 
991
/* Try to find the given state in the state stack.  */
992
 
993
gfc_try
994
gfc_find_state (gfc_compile_state state)
995
{
996
  gfc_state_data *p;
997
 
998
  for (p = gfc_state_stack; p; p = p->previous)
999
    if (p->state == state)
1000
      break;
1001
 
1002
  return (p == NULL) ? FAILURE : SUCCESS;
1003
}
1004
 
1005
 
1006
/* Starts a new level in the statement list.  */
1007
 
1008
static gfc_code *
1009
new_level (gfc_code *q)
1010
{
1011
  gfc_code *p;
1012
 
1013
  p = q->block = gfc_get_code ();
1014
 
1015
  gfc_state_stack->head = gfc_state_stack->tail = p;
1016
 
1017
  return p;
1018
}
1019
 
1020
 
1021
/* Add the current new_st code structure and adds it to the current
1022
   program unit.  As a side-effect, it zeroes the new_st.  */
1023
 
1024
static gfc_code *
1025
add_statement (void)
1026
{
1027
  gfc_code *p;
1028
 
1029
  p = gfc_get_code ();
1030
  *p = new_st;
1031
 
1032
  p->loc = gfc_current_locus;
1033
 
1034
  if (gfc_state_stack->head == NULL)
1035
    gfc_state_stack->head = p;
1036
  else
1037
    gfc_state_stack->tail->next = p;
1038
 
1039
  while (p->next != NULL)
1040
    p = p->next;
1041
 
1042
  gfc_state_stack->tail = p;
1043
 
1044
  gfc_clear_new_st ();
1045
 
1046
  return p;
1047
}
1048
 
1049
 
1050
/* Frees everything associated with the current statement.  */
1051
 
1052
static void
1053
undo_new_statement (void)
1054
{
1055
  gfc_free_statements (new_st.block);
1056
  gfc_free_statements (new_st.next);
1057
  gfc_free_statement (&new_st);
1058
  gfc_clear_new_st ();
1059
}
1060
 
1061
 
1062
/* If the current statement has a statement label, make sure that it
1063
   is allowed to, or should have one.  */
1064
 
1065
static void
1066
check_statement_label (gfc_statement st)
1067
{
1068
  gfc_sl_type type;
1069
 
1070
  if (gfc_statement_label == NULL)
1071
    {
1072
      if (st == ST_FORMAT)
1073
        gfc_error ("FORMAT statement at %L does not have a statement label",
1074
                   &new_st.loc);
1075
      return;
1076
    }
1077
 
1078
  switch (st)
1079
    {
1080
    case ST_END_PROGRAM:
1081
    case ST_END_FUNCTION:
1082
    case ST_END_SUBROUTINE:
1083
    case ST_ENDDO:
1084
    case ST_ENDIF:
1085
    case ST_END_SELECT:
1086
    case_executable:
1087
    case_exec_markers:
1088
      type = ST_LABEL_TARGET;
1089
      break;
1090
 
1091
    case ST_FORMAT:
1092
      type = ST_LABEL_FORMAT;
1093
      break;
1094
 
1095
      /* Statement labels are not restricted from appearing on a
1096
         particular line.  However, there are plenty of situations
1097
         where the resulting label can't be referenced.  */
1098
 
1099
    default:
1100
      type = ST_LABEL_BAD_TARGET;
1101
      break;
1102
    }
1103
 
1104
  gfc_define_st_label (gfc_statement_label, type, &label_locus);
1105
 
1106
  new_st.here = gfc_statement_label;
1107
}
1108
 
1109
 
1110
/* Figures out what the enclosing program unit is.  This will be a
1111
   function, subroutine, program, block data or module.  */
1112
 
1113
gfc_state_data *
1114
gfc_enclosing_unit (gfc_compile_state * result)
1115
{
1116
  gfc_state_data *p;
1117
 
1118
  for (p = gfc_state_stack; p; p = p->previous)
1119
    if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1120
        || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1121
        || p->state == COMP_PROGRAM)
1122
      {
1123
 
1124
        if (result != NULL)
1125
          *result = p->state;
1126
        return p;
1127
      }
1128
 
1129
  if (result != NULL)
1130
    *result = COMP_PROGRAM;
1131
  return NULL;
1132
}
1133
 
1134
 
1135
/* Translate a statement enum to a string.  */
1136
 
1137
const char *
1138
gfc_ascii_statement (gfc_statement st)
1139
{
1140
  const char *p;
1141
 
1142
  switch (st)
1143
    {
1144
    case ST_ARITHMETIC_IF:
1145
      p = _("arithmetic IF");
1146
      break;
1147
    case ST_ALLOCATE:
1148
      p = "ALLOCATE";
1149
      break;
1150
    case ST_ATTR_DECL:
1151
      p = _("attribute declaration");
1152
      break;
1153
    case ST_BACKSPACE:
1154
      p = "BACKSPACE";
1155
      break;
1156
    case ST_BLOCK:
1157
      p = "BLOCK";
1158
      break;
1159
    case ST_BLOCK_DATA:
1160
      p = "BLOCK DATA";
1161
      break;
1162
    case ST_CALL:
1163
      p = "CALL";
1164
      break;
1165
    case ST_CASE:
1166
      p = "CASE";
1167
      break;
1168
    case ST_CLOSE:
1169
      p = "CLOSE";
1170
      break;
1171
    case ST_COMMON:
1172
      p = "COMMON";
1173
      break;
1174
    case ST_CONTINUE:
1175
      p = "CONTINUE";
1176
      break;
1177
    case ST_CONTAINS:
1178
      p = "CONTAINS";
1179
      break;
1180
    case ST_CYCLE:
1181
      p = "CYCLE";
1182
      break;
1183
    case ST_DATA_DECL:
1184
      p = _("data declaration");
1185
      break;
1186
    case ST_DATA:
1187
      p = "DATA";
1188
      break;
1189
    case ST_DEALLOCATE:
1190
      p = "DEALLOCATE";
1191
      break;
1192
    case ST_DERIVED_DECL:
1193
      p = _("derived type declaration");
1194
      break;
1195
    case ST_DO:
1196
      p = "DO";
1197
      break;
1198
    case ST_ELSE:
1199
      p = "ELSE";
1200
      break;
1201
    case ST_ELSEIF:
1202
      p = "ELSE IF";
1203
      break;
1204
    case ST_ELSEWHERE:
1205
      p = "ELSEWHERE";
1206
      break;
1207
    case ST_END_BLOCK:
1208
      p = "END BLOCK";
1209
      break;
1210
    case ST_END_BLOCK_DATA:
1211
      p = "END BLOCK DATA";
1212
      break;
1213
    case ST_ENDDO:
1214
      p = "END DO";
1215
      break;
1216
    case ST_END_FILE:
1217
      p = "END FILE";
1218
      break;
1219
    case ST_END_FORALL:
1220
      p = "END FORALL";
1221
      break;
1222
    case ST_END_FUNCTION:
1223
      p = "END FUNCTION";
1224
      break;
1225
    case ST_ENDIF:
1226
      p = "END IF";
1227
      break;
1228
    case ST_END_INTERFACE:
1229
      p = "END INTERFACE";
1230
      break;
1231
    case ST_END_MODULE:
1232
      p = "END MODULE";
1233
      break;
1234
    case ST_END_PROGRAM:
1235
      p = "END PROGRAM";
1236
      break;
1237
    case ST_END_SELECT:
1238
      p = "END SELECT";
1239
      break;
1240
    case ST_END_SUBROUTINE:
1241
      p = "END SUBROUTINE";
1242
      break;
1243
    case ST_END_WHERE:
1244
      p = "END WHERE";
1245
      break;
1246
    case ST_END_TYPE:
1247
      p = "END TYPE";
1248
      break;
1249
    case ST_ENTRY:
1250
      p = "ENTRY";
1251
      break;
1252
    case ST_EQUIVALENCE:
1253
      p = "EQUIVALENCE";
1254
      break;
1255
    case ST_EXIT:
1256
      p = "EXIT";
1257
      break;
1258
    case ST_FLUSH:
1259
      p = "FLUSH";
1260
      break;
1261
    case ST_FORALL_BLOCK:       /* Fall through */
1262
    case ST_FORALL:
1263
      p = "FORALL";
1264
      break;
1265
    case ST_FORMAT:
1266
      p = "FORMAT";
1267
      break;
1268
    case ST_FUNCTION:
1269
      p = "FUNCTION";
1270
      break;
1271
    case ST_GENERIC:
1272
      p = "GENERIC";
1273
      break;
1274
    case ST_GOTO:
1275
      p = "GOTO";
1276
      break;
1277
    case ST_IF_BLOCK:
1278
      p = _("block IF");
1279
      break;
1280
    case ST_IMPLICIT:
1281
      p = "IMPLICIT";
1282
      break;
1283
    case ST_IMPLICIT_NONE:
1284
      p = "IMPLICIT NONE";
1285
      break;
1286
    case ST_IMPLIED_ENDDO:
1287
      p = _("implied END DO");
1288
      break;
1289
    case ST_IMPORT:
1290
      p = "IMPORT";
1291
      break;
1292
    case ST_INQUIRE:
1293
      p = "INQUIRE";
1294
      break;
1295
    case ST_INTERFACE:
1296
      p = "INTERFACE";
1297
      break;
1298
    case ST_PARAMETER:
1299
      p = "PARAMETER";
1300
      break;
1301
    case ST_PRIVATE:
1302
      p = "PRIVATE";
1303
      break;
1304
    case ST_PUBLIC:
1305
      p = "PUBLIC";
1306
      break;
1307
    case ST_MODULE:
1308
      p = "MODULE";
1309
      break;
1310
    case ST_PAUSE:
1311
      p = "PAUSE";
1312
      break;
1313
    case ST_MODULE_PROC:
1314
      p = "MODULE PROCEDURE";
1315
      break;
1316
    case ST_NAMELIST:
1317
      p = "NAMELIST";
1318
      break;
1319
    case ST_NULLIFY:
1320
      p = "NULLIFY";
1321
      break;
1322
    case ST_OPEN:
1323
      p = "OPEN";
1324
      break;
1325
    case ST_PROGRAM:
1326
      p = "PROGRAM";
1327
      break;
1328
    case ST_PROCEDURE:
1329
      p = "PROCEDURE";
1330
      break;
1331
    case ST_READ:
1332
      p = "READ";
1333
      break;
1334
    case ST_RETURN:
1335
      p = "RETURN";
1336
      break;
1337
    case ST_REWIND:
1338
      p = "REWIND";
1339
      break;
1340
    case ST_STOP:
1341
      p = "STOP";
1342
      break;
1343
    case ST_SUBROUTINE:
1344
      p = "SUBROUTINE";
1345
      break;
1346
    case ST_TYPE:
1347
      p = "TYPE";
1348
      break;
1349
    case ST_USE:
1350
      p = "USE";
1351
      break;
1352
    case ST_WHERE_BLOCK:        /* Fall through */
1353
    case ST_WHERE:
1354
      p = "WHERE";
1355
      break;
1356
    case ST_WAIT:
1357
      p = "WAIT";
1358
      break;
1359
    case ST_WRITE:
1360
      p = "WRITE";
1361
      break;
1362
    case ST_ASSIGNMENT:
1363
      p = _("assignment");
1364
      break;
1365
    case ST_POINTER_ASSIGNMENT:
1366
      p = _("pointer assignment");
1367
      break;
1368
    case ST_SELECT_CASE:
1369
      p = "SELECT CASE";
1370
      break;
1371
    case ST_SELECT_TYPE:
1372
      p = "SELECT TYPE";
1373
      break;
1374
    case ST_TYPE_IS:
1375
      p = "TYPE IS";
1376
      break;
1377
    case ST_CLASS_IS:
1378
      p = "CLASS IS";
1379
      break;
1380
    case ST_SEQUENCE:
1381
      p = "SEQUENCE";
1382
      break;
1383
    case ST_SIMPLE_IF:
1384
      p = _("simple IF");
1385
      break;
1386
    case ST_STATEMENT_FUNCTION:
1387
      p = "STATEMENT FUNCTION";
1388
      break;
1389
    case ST_LABEL_ASSIGNMENT:
1390
      p = "LABEL ASSIGNMENT";
1391
      break;
1392
    case ST_ENUM:
1393
      p = "ENUM DEFINITION";
1394
      break;
1395
    case ST_ENUMERATOR:
1396
      p = "ENUMERATOR DEFINITION";
1397
      break;
1398
    case ST_END_ENUM:
1399
      p = "END ENUM";
1400
      break;
1401
    case ST_OMP_ATOMIC:
1402
      p = "!$OMP ATOMIC";
1403
      break;
1404
    case ST_OMP_BARRIER:
1405
      p = "!$OMP BARRIER";
1406
      break;
1407
    case ST_OMP_CRITICAL:
1408
      p = "!$OMP CRITICAL";
1409
      break;
1410
    case ST_OMP_DO:
1411
      p = "!$OMP DO";
1412
      break;
1413
    case ST_OMP_END_CRITICAL:
1414
      p = "!$OMP END CRITICAL";
1415
      break;
1416
    case ST_OMP_END_DO:
1417
      p = "!$OMP END DO";
1418
      break;
1419
    case ST_OMP_END_MASTER:
1420
      p = "!$OMP END MASTER";
1421
      break;
1422
    case ST_OMP_END_ORDERED:
1423
      p = "!$OMP END ORDERED";
1424
      break;
1425
    case ST_OMP_END_PARALLEL:
1426
      p = "!$OMP END PARALLEL";
1427
      break;
1428
    case ST_OMP_END_PARALLEL_DO:
1429
      p = "!$OMP END PARALLEL DO";
1430
      break;
1431
    case ST_OMP_END_PARALLEL_SECTIONS:
1432
      p = "!$OMP END PARALLEL SECTIONS";
1433
      break;
1434
    case ST_OMP_END_PARALLEL_WORKSHARE:
1435
      p = "!$OMP END PARALLEL WORKSHARE";
1436
      break;
1437
    case ST_OMP_END_SECTIONS:
1438
      p = "!$OMP END SECTIONS";
1439
      break;
1440
    case ST_OMP_END_SINGLE:
1441
      p = "!$OMP END SINGLE";
1442
      break;
1443
    case ST_OMP_END_TASK:
1444
      p = "!$OMP END TASK";
1445
      break;
1446
    case ST_OMP_END_WORKSHARE:
1447
      p = "!$OMP END WORKSHARE";
1448
      break;
1449
    case ST_OMP_FLUSH:
1450
      p = "!$OMP FLUSH";
1451
      break;
1452
    case ST_OMP_MASTER:
1453
      p = "!$OMP MASTER";
1454
      break;
1455
    case ST_OMP_ORDERED:
1456
      p = "!$OMP ORDERED";
1457
      break;
1458
    case ST_OMP_PARALLEL:
1459
      p = "!$OMP PARALLEL";
1460
      break;
1461
    case ST_OMP_PARALLEL_DO:
1462
      p = "!$OMP PARALLEL DO";
1463
      break;
1464
    case ST_OMP_PARALLEL_SECTIONS:
1465
      p = "!$OMP PARALLEL SECTIONS";
1466
      break;
1467
    case ST_OMP_PARALLEL_WORKSHARE:
1468
      p = "!$OMP PARALLEL WORKSHARE";
1469
      break;
1470
    case ST_OMP_SECTIONS:
1471
      p = "!$OMP SECTIONS";
1472
      break;
1473
    case ST_OMP_SECTION:
1474
      p = "!$OMP SECTION";
1475
      break;
1476
    case ST_OMP_SINGLE:
1477
      p = "!$OMP SINGLE";
1478
      break;
1479
    case ST_OMP_TASK:
1480
      p = "!$OMP TASK";
1481
      break;
1482
    case ST_OMP_TASKWAIT:
1483
      p = "!$OMP TASKWAIT";
1484
      break;
1485
    case ST_OMP_THREADPRIVATE:
1486
      p = "!$OMP THREADPRIVATE";
1487
      break;
1488
    case ST_OMP_WORKSHARE:
1489
      p = "!$OMP WORKSHARE";
1490
      break;
1491
    default:
1492
      gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1493
    }
1494
 
1495
  return p;
1496
}
1497
 
1498
 
1499
/* Create a symbol for the main program and assign it to ns->proc_name.  */
1500
 
1501
static void
1502
main_program_symbol (gfc_namespace *ns, const char *name)
1503
{
1504
  gfc_symbol *main_program;
1505
  symbol_attribute attr;
1506
 
1507
  gfc_get_symbol (name, ns, &main_program);
1508
  gfc_clear_attr (&attr);
1509
  attr.flavor = FL_PROGRAM;
1510
  attr.proc = PROC_UNKNOWN;
1511
  attr.subroutine = 1;
1512
  attr.access = ACCESS_PUBLIC;
1513
  attr.is_main_program = 1;
1514
  main_program->attr = attr;
1515
  main_program->declared_at = gfc_current_locus;
1516
  ns->proc_name = main_program;
1517
  gfc_commit_symbols ();
1518
}
1519
 
1520
 
1521
/* Do whatever is necessary to accept the last statement.  */
1522
 
1523
static void
1524
accept_statement (gfc_statement st)
1525
{
1526
  switch (st)
1527
    {
1528
    case ST_USE:
1529
      gfc_use_module ();
1530
      break;
1531
 
1532
    case ST_IMPLICIT_NONE:
1533
      gfc_set_implicit_none ();
1534
      break;
1535
 
1536
    case ST_IMPLICIT:
1537
      break;
1538
 
1539
    case ST_FUNCTION:
1540
    case ST_SUBROUTINE:
1541
    case ST_MODULE:
1542
      gfc_current_ns->proc_name = gfc_new_block;
1543
      break;
1544
 
1545
      /* If the statement is the end of a block, lay down a special code
1546
         that allows a branch to the end of the block from within the
1547
         construct.  IF and SELECT are treated differently from DO
1548
         (where EXEC_NOP is added inside the loop) for two
1549
         reasons:
1550
         1. END DO has a meaning in the sense that after a GOTO to
1551
            it, the loop counter must be increased.
1552
         2. IF blocks and SELECT blocks can consist of multiple
1553
            parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1554
            Putting the label before the END IF would make the jump
1555
            from, say, the ELSE IF block to the END IF illegal.  */
1556
 
1557
    case ST_ENDIF:
1558
    case ST_END_SELECT:
1559
      if (gfc_statement_label != NULL)
1560
        {
1561
          new_st.op = EXEC_END_BLOCK;
1562
          add_statement ();
1563
        }
1564
      break;
1565
 
1566
      /* The end-of-program unit statements do not get the special
1567
         marker and require a statement of some sort if they are a
1568
         branch target.  */
1569
 
1570
    case ST_END_PROGRAM:
1571
    case ST_END_FUNCTION:
1572
    case ST_END_SUBROUTINE:
1573
      if (gfc_statement_label != NULL)
1574
        {
1575
          new_st.op = EXEC_RETURN;
1576
          add_statement ();
1577
        }
1578
      else
1579
        {
1580
          new_st.op = EXEC_END_PROCEDURE;
1581
          add_statement ();
1582
        }
1583
 
1584
      break;
1585
 
1586
    case ST_ENTRY:
1587
    case_executable:
1588
    case_exec_markers:
1589
      add_statement ();
1590
      break;
1591
 
1592
    default:
1593
      break;
1594
    }
1595
 
1596
  gfc_commit_symbols ();
1597
  gfc_warning_check ();
1598
  gfc_clear_new_st ();
1599
}
1600
 
1601
 
1602
/* Undo anything tentative that has been built for the current
1603
   statement.  */
1604
 
1605
static void
1606
reject_statement (void)
1607
{
1608
  /* Revert to the previous charlen chain.  */
1609
  gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
1610
  gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
1611
 
1612 378 julius
  gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
1613
  gfc_current_ns->equiv = gfc_current_ns->old_equiv;
1614
 
1615 285 jeremybenn
  gfc_new_block = NULL;
1616
  gfc_undo_symbols ();
1617
  gfc_clear_warning ();
1618
  undo_new_statement ();
1619
}
1620
 
1621
 
1622
/* Generic complaint about an out of order statement.  We also do
1623
   whatever is necessary to clean up.  */
1624
 
1625
static void
1626
unexpected_statement (gfc_statement st)
1627
{
1628
  gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1629
 
1630
  reject_statement ();
1631
}
1632
 
1633
 
1634
/* Given the next statement seen by the matcher, make sure that it is
1635
   in proper order with the last.  This subroutine is initialized by
1636
   calling it with an argument of ST_NONE.  If there is a problem, we
1637
   issue an error and return FAILURE.  Otherwise we return SUCCESS.
1638
 
1639
   Individual parsers need to verify that the statements seen are
1640
   valid before calling here, i.e., ENTRY statements are not allowed in
1641
   INTERFACE blocks.  The following diagram is taken from the standard:
1642
 
1643
            +---------------------------------------+
1644
            | program  subroutine  function  module |
1645
            +---------------------------------------+
1646
            |            use               |
1647
            +---------------------------------------+
1648
            |            import         |
1649
            +---------------------------------------+
1650
            |   |       implicit none    |
1651
            |   +-----------+------------------+
1652
            |   | parameter |  implicit |
1653
            |   +-----------+------------------+
1654
            | format |     |  derived type    |
1655
            | entry  | parameter |  interface       |
1656
            |   |   data    |  specification   |
1657
            |   |          |  statement func  |
1658
            |   +-----------+------------------+
1659
            |   |   data    |    executable    |
1660
            +--------+-----------+------------------+
1661
            |           contains               |
1662
            +---------------------------------------+
1663
            |      internal module/subprogram       |
1664
            +---------------------------------------+
1665
            |              end           |
1666
            +---------------------------------------+
1667
 
1668
*/
1669
 
1670
enum state_order
1671
{
1672
  ORDER_START,
1673
  ORDER_USE,
1674
  ORDER_IMPORT,
1675
  ORDER_IMPLICIT_NONE,
1676
  ORDER_IMPLICIT,
1677
  ORDER_SPEC,
1678
  ORDER_EXEC
1679
};
1680
 
1681
typedef struct
1682
{
1683
  enum state_order state;
1684
  gfc_statement last_statement;
1685
  locus where;
1686
}
1687
st_state;
1688
 
1689
static gfc_try
1690
verify_st_order (st_state *p, gfc_statement st, bool silent)
1691
{
1692
 
1693
  switch (st)
1694
    {
1695
    case ST_NONE:
1696
      p->state = ORDER_START;
1697
      break;
1698
 
1699
    case ST_USE:
1700
      if (p->state > ORDER_USE)
1701
        goto order;
1702
      p->state = ORDER_USE;
1703
      break;
1704
 
1705
    case ST_IMPORT:
1706
      if (p->state > ORDER_IMPORT)
1707
        goto order;
1708
      p->state = ORDER_IMPORT;
1709
      break;
1710
 
1711
    case ST_IMPLICIT_NONE:
1712
      if (p->state > ORDER_IMPLICIT_NONE)
1713
        goto order;
1714
 
1715
      /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1716
         statement disqualifies a USE but not an IMPLICIT NONE.
1717
         Duplicate IMPLICIT NONEs are caught when the implicit types
1718
         are set.  */
1719
 
1720
      p->state = ORDER_IMPLICIT_NONE;
1721
      break;
1722
 
1723
    case ST_IMPLICIT:
1724
      if (p->state > ORDER_IMPLICIT)
1725
        goto order;
1726
      p->state = ORDER_IMPLICIT;
1727
      break;
1728
 
1729
    case ST_FORMAT:
1730
    case ST_ENTRY:
1731
      if (p->state < ORDER_IMPLICIT_NONE)
1732
        p->state = ORDER_IMPLICIT_NONE;
1733
      break;
1734
 
1735
    case ST_PARAMETER:
1736
      if (p->state >= ORDER_EXEC)
1737
        goto order;
1738
      if (p->state < ORDER_IMPLICIT)
1739
        p->state = ORDER_IMPLICIT;
1740
      break;
1741
 
1742
    case ST_DATA:
1743
      if (p->state < ORDER_SPEC)
1744
        p->state = ORDER_SPEC;
1745
      break;
1746
 
1747
    case ST_PUBLIC:
1748
    case ST_PRIVATE:
1749
    case ST_DERIVED_DECL:
1750
    case_decl:
1751
      if (p->state >= ORDER_EXEC)
1752
        goto order;
1753
      if (p->state < ORDER_SPEC)
1754
        p->state = ORDER_SPEC;
1755
      break;
1756
 
1757
    case_executable:
1758
    case_exec_markers:
1759
      if (p->state < ORDER_EXEC)
1760
        p->state = ORDER_EXEC;
1761
      break;
1762
 
1763
    default:
1764
      gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1765
                          gfc_ascii_statement (st));
1766
    }
1767
 
1768
  /* All is well, record the statement in case we need it next time.  */
1769
  p->where = gfc_current_locus;
1770
  p->last_statement = st;
1771
  return SUCCESS;
1772
 
1773
order:
1774
  if (!silent)
1775
    gfc_error ("%s statement at %C cannot follow %s statement at %L",
1776
               gfc_ascii_statement (st),
1777
               gfc_ascii_statement (p->last_statement), &p->where);
1778
 
1779
  return FAILURE;
1780
}
1781
 
1782
 
1783
/* Handle an unexpected end of file.  This is a show-stopper...  */
1784
 
1785
static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1786
 
1787
static void
1788
unexpected_eof (void)
1789
{
1790
  gfc_state_data *p;
1791
 
1792
  gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1793
 
1794
  /* Memory cleanup.  Move to "second to last".  */
1795
  for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1796
       p = p->previous);
1797
 
1798
  gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1799
  gfc_done_2 ();
1800
 
1801
  longjmp (eof_buf, 1);
1802
}
1803
 
1804
 
1805
/* Parse the CONTAINS section of a derived type definition.  */
1806
 
1807
gfc_access gfc_typebound_default_access;
1808
 
1809
static bool
1810
parse_derived_contains (void)
1811
{
1812
  gfc_state_data s;
1813
  bool seen_private = false;
1814
  bool seen_comps = false;
1815
  bool error_flag = false;
1816
  bool to_finish;
1817
 
1818
  gcc_assert (gfc_current_state () == COMP_DERIVED);
1819
  gcc_assert (gfc_current_block ());
1820
 
1821
  /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1822
     section.  */
1823
  if (gfc_current_block ()->attr.sequence)
1824
    gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1825
               " section at %C", gfc_current_block ()->name);
1826
  if (gfc_current_block ()->attr.is_bind_c)
1827
    gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1828
               " section at %C", gfc_current_block ()->name);
1829
 
1830
  accept_statement (ST_CONTAINS);
1831
  push_state (&s, COMP_DERIVED_CONTAINS, NULL);
1832
 
1833
  gfc_typebound_default_access = ACCESS_PUBLIC;
1834
 
1835
  to_finish = false;
1836
  while (!to_finish)
1837
    {
1838
      gfc_statement st;
1839
      st = next_statement ();
1840
      switch (st)
1841
        {
1842
        case ST_NONE:
1843
          unexpected_eof ();
1844
          break;
1845
 
1846
        case ST_DATA_DECL:
1847
          gfc_error ("Components in TYPE at %C must precede CONTAINS");
1848 378 julius
          goto error;
1849 285 jeremybenn
 
1850
        case ST_PROCEDURE:
1851
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  Type-bound"
1852
                                             " procedure at %C") == FAILURE)
1853 378 julius
            goto error;
1854 285 jeremybenn
 
1855
          accept_statement (ST_PROCEDURE);
1856
          seen_comps = true;
1857
          break;
1858
 
1859
        case ST_GENERIC:
1860
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  GENERIC binding"
1861
                                             " at %C") == FAILURE)
1862 378 julius
            goto error;
1863 285 jeremybenn
 
1864
          accept_statement (ST_GENERIC);
1865
          seen_comps = true;
1866
          break;
1867
 
1868
        case ST_FINAL:
1869
          if (gfc_notify_std (GFC_STD_F2003,
1870
                              "Fortran 2003:  FINAL procedure declaration"
1871
                              " at %C") == FAILURE)
1872 378 julius
            goto error;
1873 285 jeremybenn
 
1874
          accept_statement (ST_FINAL);
1875
          seen_comps = true;
1876
          break;
1877
 
1878
        case ST_END_TYPE:
1879
          to_finish = true;
1880
 
1881
          if (!seen_comps
1882
              && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
1883
                                  "definition at %C with empty CONTAINS "
1884
                                  "section") == FAILURE))
1885 378 julius
            goto error;
1886 285 jeremybenn
 
1887
          /* ST_END_TYPE is accepted by parse_derived after return.  */
1888
          break;
1889
 
1890
        case ST_PRIVATE:
1891
          if (gfc_find_state (COMP_MODULE) == FAILURE)
1892
            {
1893
              gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1894
                         "a MODULE");
1895 378 julius
              goto error;
1896 285 jeremybenn
            }
1897
 
1898
          if (seen_comps)
1899
            {
1900
              gfc_error ("PRIVATE statement at %C must precede procedure"
1901
                         " bindings");
1902 378 julius
              goto error;
1903 285 jeremybenn
            }
1904
 
1905
          if (seen_private)
1906
            {
1907
              gfc_error ("Duplicate PRIVATE statement at %C");
1908 378 julius
              goto error;
1909 285 jeremybenn
            }
1910
 
1911
          accept_statement (ST_PRIVATE);
1912
          gfc_typebound_default_access = ACCESS_PRIVATE;
1913
          seen_private = true;
1914
          break;
1915
 
1916
        case ST_SEQUENCE:
1917
          gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1918 378 julius
          goto error;
1919 285 jeremybenn
 
1920
        case ST_CONTAINS:
1921
          gfc_error ("Already inside a CONTAINS block at %C");
1922 378 julius
          goto error;
1923 285 jeremybenn
 
1924
        default:
1925
          unexpected_statement (st);
1926
          break;
1927
        }
1928 378 julius
 
1929
      continue;
1930
 
1931
error:
1932
      error_flag = true;
1933
      reject_statement ();
1934 285 jeremybenn
    }
1935
 
1936
  pop_state ();
1937
  gcc_assert (gfc_current_state () == COMP_DERIVED);
1938
 
1939
  return error_flag;
1940
}
1941
 
1942
 
1943
/* Parse a derived type.  */
1944
 
1945
static void
1946
parse_derived (void)
1947
{
1948
  int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1949
  gfc_statement st;
1950
  gfc_state_data s;
1951
  gfc_symbol *sym;
1952
  gfc_component *c;
1953
 
1954
  error_flag = 0;
1955
 
1956
  accept_statement (ST_DERIVED_DECL);
1957
  push_state (&s, COMP_DERIVED, gfc_new_block);
1958
 
1959
  gfc_new_block->component_access = ACCESS_PUBLIC;
1960
  seen_private = 0;
1961
  seen_sequence = 0;
1962
  seen_component = 0;
1963
 
1964
  compiling_type = 1;
1965
 
1966
  while (compiling_type)
1967
    {
1968
      st = next_statement ();
1969
      switch (st)
1970
        {
1971
        case ST_NONE:
1972
          unexpected_eof ();
1973
 
1974
        case ST_DATA_DECL:
1975
        case ST_PROCEDURE:
1976
          accept_statement (st);
1977
          seen_component = 1;
1978
          break;
1979
 
1980
        case ST_FINAL:
1981
          gfc_error ("FINAL declaration at %C must be inside CONTAINS");
1982
          error_flag = 1;
1983
          break;
1984
 
1985
        case ST_END_TYPE:
1986
endType:
1987
          compiling_type = 0;
1988
 
1989
          if (!seen_component
1990
              && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
1991
                                 "definition at %C without components")
1992
                  == FAILURE))
1993
            error_flag = 1;
1994
 
1995
          accept_statement (ST_END_TYPE);
1996
          break;
1997
 
1998
        case ST_PRIVATE:
1999
          if (gfc_find_state (COMP_MODULE) == FAILURE)
2000
            {
2001
              gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2002
                         "a MODULE");
2003
              error_flag = 1;
2004
              break;
2005
            }
2006
 
2007
          if (seen_component)
2008
            {
2009
              gfc_error ("PRIVATE statement at %C must precede "
2010
                         "structure components");
2011
              error_flag = 1;
2012
              break;
2013
            }
2014
 
2015
          if (seen_private)
2016
            {
2017
              gfc_error ("Duplicate PRIVATE statement at %C");
2018
              error_flag = 1;
2019
            }
2020
 
2021
          s.sym->component_access = ACCESS_PRIVATE;
2022
 
2023
          accept_statement (ST_PRIVATE);
2024
          seen_private = 1;
2025
          break;
2026
 
2027
        case ST_SEQUENCE:
2028
          if (seen_component)
2029
            {
2030
              gfc_error ("SEQUENCE statement at %C must precede "
2031
                         "structure components");
2032
              error_flag = 1;
2033
              break;
2034
            }
2035
 
2036
          if (gfc_current_block ()->attr.sequence)
2037
            gfc_warning ("SEQUENCE attribute at %C already specified in "
2038
                         "TYPE statement");
2039
 
2040
          if (seen_sequence)
2041
            {
2042
              gfc_error ("Duplicate SEQUENCE statement at %C");
2043
              error_flag = 1;
2044
            }
2045
 
2046
          seen_sequence = 1;
2047
          gfc_add_sequence (&gfc_current_block ()->attr,
2048
                            gfc_current_block ()->name, NULL);
2049
          break;
2050
 
2051
        case ST_CONTAINS:
2052
          if (gfc_notify_std (GFC_STD_F2003,
2053
                              "Fortran 2003:  CONTAINS block in derived type"
2054
                              " definition at %C") == FAILURE)
2055
            error_flag = 1;
2056
 
2057
          accept_statement (ST_CONTAINS);
2058
          if (parse_derived_contains ())
2059
            error_flag = 1;
2060
          goto endType;
2061
 
2062
        default:
2063
          unexpected_statement (st);
2064
          break;
2065
        }
2066
    }
2067
 
2068
  /* need to verify that all fields of the derived type are
2069
   * interoperable with C if the type is declared to be bind(c)
2070
   */
2071
  sym = gfc_current_block ();
2072
  for (c = sym->components; c; c = c->next)
2073
    {
2074
      /* Look for allocatable components.  */
2075
      if (c->attr.allocatable
2076
          || (c->ts.type == BT_CLASS
2077
              && c->ts.u.derived->components->attr.allocatable)
2078
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2079
        sym->attr.alloc_comp = 1;
2080
 
2081
      /* Look for pointer components.  */
2082
      if (c->attr.pointer
2083
          || (c->ts.type == BT_CLASS
2084
              && c->ts.u.derived->components->attr.pointer)
2085
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2086
        sym->attr.pointer_comp = 1;
2087
 
2088
      /* Look for procedure pointer components.  */
2089
      if (c->attr.proc_pointer
2090
          || (c->ts.type == BT_DERIVED
2091
              && c->ts.u.derived->attr.proc_pointer_comp))
2092
        sym->attr.proc_pointer_comp = 1;
2093
 
2094
      /* Look for private components.  */
2095
      if (sym->component_access == ACCESS_PRIVATE
2096
          || c->attr.access == ACCESS_PRIVATE
2097
          || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2098
        sym->attr.private_comp = 1;
2099
    }
2100
 
2101
  if (!seen_component)
2102
    sym->attr.zero_comp = 1;
2103
 
2104
  pop_state ();
2105
}
2106
 
2107
 
2108
/* Parse an ENUM.  */
2109
 
2110
static void
2111
parse_enum (void)
2112
{
2113
  int error_flag;
2114
  gfc_statement st;
2115
  int compiling_enum;
2116
  gfc_state_data s;
2117
  int seen_enumerator = 0;
2118
 
2119
  error_flag = 0;
2120
 
2121
  push_state (&s, COMP_ENUM, gfc_new_block);
2122
 
2123
  compiling_enum = 1;
2124
 
2125
  while (compiling_enum)
2126
    {
2127
      st = next_statement ();
2128
      switch (st)
2129
        {
2130
        case ST_NONE:
2131
          unexpected_eof ();
2132
          break;
2133
 
2134
        case ST_ENUMERATOR:
2135
          seen_enumerator = 1;
2136
          accept_statement (st);
2137
          break;
2138
 
2139
        case ST_END_ENUM:
2140
          compiling_enum = 0;
2141
          if (!seen_enumerator)
2142
            {
2143
              gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2144
              error_flag = 1;
2145
            }
2146
          accept_statement (st);
2147
          break;
2148
 
2149
        default:
2150
          gfc_free_enum_history ();
2151
          unexpected_statement (st);
2152
          break;
2153
        }
2154
    }
2155
  pop_state ();
2156
}
2157
 
2158
 
2159
/* Parse an interface.  We must be able to deal with the possibility
2160
   of recursive interfaces.  The parse_spec() subroutine is mutually
2161
   recursive with parse_interface().  */
2162
 
2163
static gfc_statement parse_spec (gfc_statement);
2164
 
2165
static void
2166
parse_interface (void)
2167
{
2168
  gfc_compile_state new_state = COMP_NONE, current_state;
2169
  gfc_symbol *prog_unit, *sym;
2170
  gfc_interface_info save;
2171
  gfc_state_data s1, s2;
2172
  gfc_statement st;
2173
  locus proc_locus;
2174
 
2175
  accept_statement (ST_INTERFACE);
2176
 
2177
  current_interface.ns = gfc_current_ns;
2178
  save = current_interface;
2179
 
2180
  sym = (current_interface.type == INTERFACE_GENERIC
2181
         || current_interface.type == INTERFACE_USER_OP)
2182
        ? gfc_new_block : NULL;
2183
 
2184
  push_state (&s1, COMP_INTERFACE, sym);
2185
  current_state = COMP_NONE;
2186
 
2187
loop:
2188
  gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2189
 
2190
  st = next_statement ();
2191
  switch (st)
2192
    {
2193
    case ST_NONE:
2194
      unexpected_eof ();
2195
 
2196
    case ST_SUBROUTINE:
2197
    case ST_FUNCTION:
2198
      if (st == ST_SUBROUTINE)
2199
        new_state = COMP_SUBROUTINE;
2200
      else if (st == ST_FUNCTION)
2201
        new_state = COMP_FUNCTION;
2202
      if (gfc_new_block->attr.pointer)
2203
        {
2204
          gfc_new_block->attr.pointer = 0;
2205
          gfc_new_block->attr.proc_pointer = 1;
2206
        }
2207
      if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2208
                                  gfc_new_block->formal, NULL) == FAILURE)
2209
        {
2210
          reject_statement ();
2211
          gfc_free_namespace (gfc_current_ns);
2212
          goto loop;
2213
        }
2214
      break;
2215
 
2216
    case ST_PROCEDURE:
2217
    case ST_MODULE_PROC:        /* The module procedure matcher makes
2218
                                   sure the context is correct.  */
2219
      accept_statement (st);
2220
      gfc_free_namespace (gfc_current_ns);
2221
      goto loop;
2222
 
2223
    case ST_END_INTERFACE:
2224
      gfc_free_namespace (gfc_current_ns);
2225
      gfc_current_ns = current_interface.ns;
2226
      goto done;
2227
 
2228
    default:
2229
      gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2230
                 gfc_ascii_statement (st));
2231
      reject_statement ();
2232
      gfc_free_namespace (gfc_current_ns);
2233
      goto loop;
2234
    }
2235
 
2236
 
2237
  /* Make sure that a generic interface has only subroutines or
2238
     functions and that the generic name has the right attribute.  */
2239
  if (current_interface.type == INTERFACE_GENERIC)
2240
    {
2241
      if (current_state == COMP_NONE)
2242
        {
2243
          if (new_state == COMP_FUNCTION && sym)
2244
            gfc_add_function (&sym->attr, sym->name, NULL);
2245
          else if (new_state == COMP_SUBROUTINE && sym)
2246
            gfc_add_subroutine (&sym->attr, sym->name, NULL);
2247
 
2248
          current_state = new_state;
2249
        }
2250
      else
2251
        {
2252
          if (new_state != current_state)
2253
            {
2254
              if (new_state == COMP_SUBROUTINE)
2255
                gfc_error ("SUBROUTINE at %C does not belong in a "
2256
                           "generic function interface");
2257
 
2258
              if (new_state == COMP_FUNCTION)
2259
                gfc_error ("FUNCTION at %C does not belong in a "
2260
                           "generic subroutine interface");
2261
            }
2262
        }
2263
    }
2264
 
2265
  if (current_interface.type == INTERFACE_ABSTRACT)
2266
    {
2267
      gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2268
      if (gfc_is_intrinsic_typename (gfc_new_block->name))
2269
        gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2270
                   "cannot be the same as an intrinsic type",
2271
                   gfc_new_block->name);
2272
    }
2273
 
2274
  push_state (&s2, new_state, gfc_new_block);
2275
  accept_statement (st);
2276
  prog_unit = gfc_new_block;
2277
  prog_unit->formal_ns = gfc_current_ns;
2278
  proc_locus = gfc_current_locus;
2279
 
2280
decl:
2281
  /* Read data declaration statements.  */
2282
  st = parse_spec (ST_NONE);
2283
 
2284
  /* Since the interface block does not permit an IMPLICIT statement,
2285
     the default type for the function or the result must be taken
2286
     from the formal namespace.  */
2287
  if (new_state == COMP_FUNCTION)
2288
    {
2289
        if (prog_unit->result == prog_unit
2290
              && prog_unit->ts.type == BT_UNKNOWN)
2291
          gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2292
        else if (prog_unit->result != prog_unit
2293
                   && prog_unit->result->ts.type == BT_UNKNOWN)
2294
          gfc_set_default_type (prog_unit->result, 1,
2295
                                prog_unit->formal_ns);
2296
    }
2297
 
2298
  if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2299
    {
2300
      gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2301
                 gfc_ascii_statement (st));
2302
      reject_statement ();
2303
      goto decl;
2304
    }
2305
 
2306
  /* Add EXTERNAL attribute to function or subroutine.  */
2307
  if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2308
    gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2309
 
2310
  current_interface = save;
2311
  gfc_add_interface (prog_unit);
2312
  pop_state ();
2313
 
2314
  if (current_interface.ns
2315
        && current_interface.ns->proc_name
2316
        && strcmp (current_interface.ns->proc_name->name,
2317
                   prog_unit->name) == 0)
2318
    gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2319
               "enclosing procedure", prog_unit->name, &proc_locus);
2320
 
2321
  goto loop;
2322
 
2323
done:
2324
  pop_state ();
2325
}
2326
 
2327
 
2328
/* Associate function characteristics by going back to the function
2329
   declaration and rematching the prefix.  */
2330
 
2331
static match
2332
match_deferred_characteristics (gfc_typespec * ts)
2333
{
2334
  locus loc;
2335
  match m = MATCH_ERROR;
2336
  char name[GFC_MAX_SYMBOL_LEN + 1];
2337
 
2338
  loc = gfc_current_locus;
2339
 
2340
  gfc_current_locus = gfc_current_block ()->declared_at;
2341
 
2342
  gfc_clear_error ();
2343
  gfc_buffer_error (1);
2344
  m = gfc_match_prefix (ts);
2345
  gfc_buffer_error (0);
2346
 
2347
  if (ts->type == BT_DERIVED)
2348
    {
2349
      ts->kind = 0;
2350
 
2351
      if (!ts->u.derived)
2352
        m = MATCH_ERROR;
2353
    }
2354
 
2355
  /* Only permit one go at the characteristic association.  */
2356
  if (ts->kind == -1)
2357
    ts->kind = 0;
2358
 
2359
  /* Set the function locus correctly.  If we have not found the
2360
     function name, there is an error.  */
2361
  if (m == MATCH_YES
2362
      && gfc_match ("function% %n", name) == MATCH_YES
2363
      && strcmp (name, gfc_current_block ()->name) == 0)
2364
    {
2365
      gfc_current_block ()->declared_at = gfc_current_locus;
2366
      gfc_commit_symbols ();
2367
    }
2368
  else
2369 378 julius
    {
2370
      gfc_error_check ();
2371
      gfc_undo_symbols ();
2372
    }
2373 285 jeremybenn
 
2374
  gfc_current_locus =loc;
2375
  return m;
2376
}
2377
 
2378
 
2379
/* Check specification-expressions in the function result of the currently
2380
   parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2381
   For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2382
   scope are not yet parsed so this has to be delayed up to parse_spec.  */
2383
 
2384
static void
2385
check_function_result_typed (void)
2386
{
2387
  gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2388
 
2389
  gcc_assert (gfc_current_state () == COMP_FUNCTION);
2390
  gcc_assert (ts->type != BT_UNKNOWN);
2391
 
2392
  /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
2393
  /* TODO:  Extend when KIND type parameters are implemented.  */
2394
  if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2395
    gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2396
}
2397
 
2398
 
2399
/* Parse a set of specification statements.  Returns the statement
2400
   that doesn't fit.  */
2401
 
2402
static gfc_statement
2403
parse_spec (gfc_statement st)
2404
{
2405
  st_state ss;
2406
  bool function_result_typed = false;
2407
  bool bad_characteristic = false;
2408
  gfc_typespec *ts;
2409
 
2410
  verify_st_order (&ss, ST_NONE, false);
2411
  if (st == ST_NONE)
2412
    st = next_statement ();
2413
 
2414
  /* If we are not inside a function or don't have a result specified so far,
2415
     do nothing special about it.  */
2416
  if (gfc_current_state () != COMP_FUNCTION)
2417
    function_result_typed = true;
2418
  else
2419
    {
2420
      gfc_symbol* proc = gfc_current_ns->proc_name;
2421
      gcc_assert (proc);
2422
 
2423
      if (proc->result->ts.type == BT_UNKNOWN)
2424
        function_result_typed = true;
2425
    }
2426
 
2427
loop:
2428
 
2429
  /* If we're inside a BLOCK construct, some statements are disallowed.
2430
     Check this here.  Attribute declaration statements like INTENT, OPTIONAL
2431
     or VALUE are also disallowed, but they don't have a particular ST_*
2432
     key so we have to check for them individually in their matcher routine.  */
2433
  if (gfc_current_state () == COMP_BLOCK)
2434
    switch (st)
2435
      {
2436
        case ST_IMPLICIT:
2437
        case ST_IMPLICIT_NONE:
2438
        case ST_NAMELIST:
2439
        case ST_COMMON:
2440
        case ST_EQUIVALENCE:
2441
        case ST_STATEMENT_FUNCTION:
2442
          gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2443
                     gfc_ascii_statement (st));
2444 378 julius
          reject_statement ();
2445 285 jeremybenn
          break;
2446
 
2447
        default:
2448
          break;
2449
      }
2450
 
2451
  /* If we find a statement that can not be followed by an IMPLICIT statement
2452
     (and thus we can expect to see none any further), type the function result
2453
     if it has not yet been typed.  Be careful not to give the END statement
2454
     to verify_st_order!  */
2455
  if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2456
    {
2457
      bool verify_now = false;
2458
 
2459
      if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2460
        verify_now = true;
2461
      else
2462
        {
2463
          st_state dummyss;
2464
          verify_st_order (&dummyss, ST_NONE, false);
2465
          verify_st_order (&dummyss, st, false);
2466
 
2467
          if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2468
            verify_now = true;
2469
        }
2470
 
2471
      if (verify_now)
2472
        {
2473
          check_function_result_typed ();
2474
          function_result_typed = true;
2475
        }
2476
    }
2477
 
2478
  switch (st)
2479
    {
2480
    case ST_NONE:
2481
      unexpected_eof ();
2482
 
2483
    case ST_IMPLICIT_NONE:
2484
    case ST_IMPLICIT:
2485
      if (!function_result_typed)
2486
        {
2487
          check_function_result_typed ();
2488
          function_result_typed = true;
2489
        }
2490
      goto declSt;
2491
 
2492
    case ST_FORMAT:
2493
    case ST_ENTRY:
2494
    case ST_DATA:       /* Not allowed in interfaces */
2495
      if (gfc_current_state () == COMP_INTERFACE)
2496
        break;
2497
 
2498
      /* Fall through */
2499
 
2500
    case ST_USE:
2501
    case ST_IMPORT:
2502
    case ST_PARAMETER:
2503
    case ST_PUBLIC:
2504
    case ST_PRIVATE:
2505
    case ST_DERIVED_DECL:
2506
    case_decl:
2507
declSt:
2508
      if (verify_st_order (&ss, st, false) == FAILURE)
2509
        {
2510
          reject_statement ();
2511
          st = next_statement ();
2512
          goto loop;
2513
        }
2514
 
2515
      switch (st)
2516
        {
2517
        case ST_INTERFACE:
2518
          parse_interface ();
2519
          break;
2520
 
2521
        case ST_DERIVED_DECL:
2522
          parse_derived ();
2523
          break;
2524
 
2525
        case ST_PUBLIC:
2526
        case ST_PRIVATE:
2527
          if (gfc_current_state () != COMP_MODULE)
2528
            {
2529
              gfc_error ("%s statement must appear in a MODULE",
2530
                         gfc_ascii_statement (st));
2531 378 julius
              reject_statement ();
2532 285 jeremybenn
              break;
2533
            }
2534
 
2535
          if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2536
            {
2537
              gfc_error ("%s statement at %C follows another accessibility "
2538
                         "specification", gfc_ascii_statement (st));
2539 378 julius
              reject_statement ();
2540 285 jeremybenn
              break;
2541
            }
2542
 
2543
          gfc_current_ns->default_access = (st == ST_PUBLIC)
2544
            ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2545
 
2546
          break;
2547
 
2548
        case ST_STATEMENT_FUNCTION:
2549
          if (gfc_current_state () == COMP_MODULE)
2550
            {
2551
              unexpected_statement (st);
2552
              break;
2553
            }
2554
 
2555
        default:
2556
          break;
2557
        }
2558
 
2559
      accept_statement (st);
2560
      st = next_statement ();
2561
      goto loop;
2562
 
2563
    case ST_ENUM:
2564
      accept_statement (st);
2565
      parse_enum();
2566
      st = next_statement ();
2567
      goto loop;
2568
 
2569
    case ST_GET_FCN_CHARACTERISTICS:
2570
      /* This statement triggers the association of a function's result
2571
         characteristics.  */
2572
      ts = &gfc_current_block ()->result->ts;
2573
      if (match_deferred_characteristics (ts) != MATCH_YES)
2574
        bad_characteristic = true;
2575
 
2576
      st = next_statement ();
2577
      goto loop;
2578
 
2579
    default:
2580
      break;
2581
    }
2582
 
2583
  /* If match_deferred_characteristics failed, then there is an error. */
2584
  if (bad_characteristic)
2585
    {
2586
      ts = &gfc_current_block ()->result->ts;
2587
      if (ts->type != BT_DERIVED)
2588
        gfc_error ("Bad kind expression for function '%s' at %L",
2589
                   gfc_current_block ()->name,
2590
                   &gfc_current_block ()->declared_at);
2591
      else
2592
        gfc_error ("The type for function '%s' at %L is not accessible",
2593
                   gfc_current_block ()->name,
2594
                   &gfc_current_block ()->declared_at);
2595
 
2596
      gfc_current_block ()->ts.kind = 0;
2597
      /* Keep the derived type; if it's bad, it will be discovered later.  */
2598
      if (!(ts->type == BT_DERIVED && ts->u.derived))
2599
        ts->type = BT_UNKNOWN;
2600
    }
2601
 
2602
  return st;
2603
}
2604
 
2605
 
2606
/* Parse a WHERE block, (not a simple WHERE statement).  */
2607
 
2608
static void
2609
parse_where_block (void)
2610
{
2611
  int seen_empty_else;
2612
  gfc_code *top, *d;
2613
  gfc_state_data s;
2614
  gfc_statement st;
2615
 
2616
  accept_statement (ST_WHERE_BLOCK);
2617
  top = gfc_state_stack->tail;
2618
 
2619
  push_state (&s, COMP_WHERE, gfc_new_block);
2620
 
2621
  d = add_statement ();
2622
  d->expr1 = top->expr1;
2623
  d->op = EXEC_WHERE;
2624
 
2625
  top->expr1 = NULL;
2626
  top->block = d;
2627
 
2628
  seen_empty_else = 0;
2629
 
2630
  do
2631
    {
2632
      st = next_statement ();
2633
      switch (st)
2634
        {
2635
        case ST_NONE:
2636
          unexpected_eof ();
2637
 
2638
        case ST_WHERE_BLOCK:
2639
          parse_where_block ();
2640
          break;
2641
 
2642
        case ST_ASSIGNMENT:
2643
        case ST_WHERE:
2644
          accept_statement (st);
2645
          break;
2646
 
2647
        case ST_ELSEWHERE:
2648
          if (seen_empty_else)
2649
            {
2650
              gfc_error ("ELSEWHERE statement at %C follows previous "
2651
                         "unmasked ELSEWHERE");
2652
              break;
2653
            }
2654
 
2655
          if (new_st.expr1 == NULL)
2656
            seen_empty_else = 1;
2657
 
2658
          d = new_level (gfc_state_stack->head);
2659
          d->op = EXEC_WHERE;
2660
          d->expr1 = new_st.expr1;
2661
 
2662
          accept_statement (st);
2663
 
2664
          break;
2665
 
2666
        case ST_END_WHERE:
2667
          accept_statement (st);
2668
          break;
2669
 
2670
        default:
2671
          gfc_error ("Unexpected %s statement in WHERE block at %C",
2672
                     gfc_ascii_statement (st));
2673
          reject_statement ();
2674
          break;
2675
        }
2676
    }
2677
  while (st != ST_END_WHERE);
2678
 
2679
  pop_state ();
2680
}
2681
 
2682
 
2683
/* Parse a FORALL block (not a simple FORALL statement).  */
2684
 
2685
static void
2686
parse_forall_block (void)
2687
{
2688
  gfc_code *top, *d;
2689
  gfc_state_data s;
2690
  gfc_statement st;
2691
 
2692
  accept_statement (ST_FORALL_BLOCK);
2693
  top = gfc_state_stack->tail;
2694
 
2695
  push_state (&s, COMP_FORALL, gfc_new_block);
2696
 
2697
  d = add_statement ();
2698
  d->op = EXEC_FORALL;
2699
  top->block = d;
2700
 
2701
  do
2702
    {
2703
      st = next_statement ();
2704
      switch (st)
2705
        {
2706
 
2707
        case ST_ASSIGNMENT:
2708
        case ST_POINTER_ASSIGNMENT:
2709
        case ST_WHERE:
2710
        case ST_FORALL:
2711
          accept_statement (st);
2712
          break;
2713
 
2714
        case ST_WHERE_BLOCK:
2715
          parse_where_block ();
2716
          break;
2717
 
2718
        case ST_FORALL_BLOCK:
2719
          parse_forall_block ();
2720
          break;
2721
 
2722
        case ST_END_FORALL:
2723
          accept_statement (st);
2724
          break;
2725
 
2726
        case ST_NONE:
2727
          unexpected_eof ();
2728
 
2729
        default:
2730
          gfc_error ("Unexpected %s statement in FORALL block at %C",
2731
                     gfc_ascii_statement (st));
2732
 
2733
          reject_statement ();
2734
          break;
2735
        }
2736
    }
2737
  while (st != ST_END_FORALL);
2738
 
2739
  pop_state ();
2740
}
2741
 
2742
 
2743
static gfc_statement parse_executable (gfc_statement);
2744
 
2745
/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2746
 
2747
static void
2748
parse_if_block (void)
2749
{
2750
  gfc_code *top, *d;
2751
  gfc_statement st;
2752
  locus else_locus;
2753
  gfc_state_data s;
2754
  int seen_else;
2755
 
2756
  seen_else = 0;
2757
  accept_statement (ST_IF_BLOCK);
2758
 
2759
  top = gfc_state_stack->tail;
2760
  push_state (&s, COMP_IF, gfc_new_block);
2761
 
2762
  new_st.op = EXEC_IF;
2763
  d = add_statement ();
2764
 
2765
  d->expr1 = top->expr1;
2766
  top->expr1 = NULL;
2767
  top->block = d;
2768
 
2769
  do
2770
    {
2771
      st = parse_executable (ST_NONE);
2772
 
2773
      switch (st)
2774
        {
2775
        case ST_NONE:
2776
          unexpected_eof ();
2777
 
2778
        case ST_ELSEIF:
2779
          if (seen_else)
2780
            {
2781
              gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2782
                         "statement at %L", &else_locus);
2783
 
2784
              reject_statement ();
2785
              break;
2786
            }
2787
 
2788
          d = new_level (gfc_state_stack->head);
2789
          d->op = EXEC_IF;
2790
          d->expr1 = new_st.expr1;
2791
 
2792
          accept_statement (st);
2793
 
2794
          break;
2795
 
2796
        case ST_ELSE:
2797
          if (seen_else)
2798
            {
2799
              gfc_error ("Duplicate ELSE statements at %L and %C",
2800
                         &else_locus);
2801
              reject_statement ();
2802
              break;
2803
            }
2804
 
2805
          seen_else = 1;
2806
          else_locus = gfc_current_locus;
2807
 
2808
          d = new_level (gfc_state_stack->head);
2809
          d->op = EXEC_IF;
2810
 
2811
          accept_statement (st);
2812
 
2813
          break;
2814
 
2815
        case ST_ENDIF:
2816
          break;
2817
 
2818
        default:
2819
          unexpected_statement (st);
2820
          break;
2821
        }
2822
    }
2823
  while (st != ST_ENDIF);
2824
 
2825
  pop_state ();
2826
  accept_statement (st);
2827
}
2828
 
2829
 
2830
/* Parse a SELECT block.  */
2831
 
2832
static void
2833
parse_select_block (void)
2834
{
2835
  gfc_statement st;
2836
  gfc_code *cp;
2837
  gfc_state_data s;
2838
 
2839
  accept_statement (ST_SELECT_CASE);
2840
 
2841
  cp = gfc_state_stack->tail;
2842
  push_state (&s, COMP_SELECT, gfc_new_block);
2843
 
2844
  /* Make sure that the next statement is a CASE or END SELECT.  */
2845
  for (;;)
2846
    {
2847
      st = next_statement ();
2848
      if (st == ST_NONE)
2849
        unexpected_eof ();
2850
      if (st == ST_END_SELECT)
2851
        {
2852
          /* Empty SELECT CASE is OK.  */
2853
          accept_statement (st);
2854
          pop_state ();
2855
          return;
2856
        }
2857
      if (st == ST_CASE)
2858
        break;
2859
 
2860
      gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2861
                 "CASE at %C");
2862
 
2863
      reject_statement ();
2864
    }
2865
 
2866
  /* At this point, we're got a nonempty select block.  */
2867
  cp = new_level (cp);
2868
  *cp = new_st;
2869
 
2870
  accept_statement (st);
2871
 
2872
  do
2873
    {
2874
      st = parse_executable (ST_NONE);
2875
      switch (st)
2876
        {
2877
        case ST_NONE:
2878
          unexpected_eof ();
2879
 
2880
        case ST_CASE:
2881
          cp = new_level (gfc_state_stack->head);
2882
          *cp = new_st;
2883
          gfc_clear_new_st ();
2884
 
2885
          accept_statement (st);
2886
          /* Fall through */
2887
 
2888
        case ST_END_SELECT:
2889
          break;
2890
 
2891
        /* Can't have an executable statement because of
2892
           parse_executable().  */
2893
        default:
2894
          unexpected_statement (st);
2895
          break;
2896
        }
2897
    }
2898
  while (st != ST_END_SELECT);
2899
 
2900
  pop_state ();
2901
  accept_statement (st);
2902
}
2903
 
2904
 
2905
/* Pop the current selector from the SELECT TYPE stack.  */
2906
 
2907
static void
2908
select_type_pop (void)
2909
{
2910
  gfc_select_type_stack *old = select_type_stack;
2911
  select_type_stack = old->prev;
2912
  gfc_free (old);
2913
}
2914
 
2915
 
2916
/* Parse a SELECT TYPE construct (F03:R821).  */
2917
 
2918
static void
2919
parse_select_type_block (void)
2920
{
2921
  gfc_statement st;
2922
  gfc_code *cp;
2923
  gfc_state_data s;
2924
 
2925
  accept_statement (ST_SELECT_TYPE);
2926
 
2927
  cp = gfc_state_stack->tail;
2928
  push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
2929
 
2930
  /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2931
     or END SELECT.  */
2932
  for (;;)
2933
    {
2934
      st = next_statement ();
2935
      if (st == ST_NONE)
2936
        unexpected_eof ();
2937
      if (st == ST_END_SELECT)
2938
        /* Empty SELECT CASE is OK.  */
2939
        goto done;
2940
      if (st == ST_TYPE_IS || st == ST_CLASS_IS)
2941
        break;
2942
 
2943
      gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2944
                 "following SELECT TYPE at %C");
2945
 
2946
      reject_statement ();
2947
    }
2948
 
2949
  /* At this point, we're got a nonempty select block.  */
2950
  cp = new_level (cp);
2951
  *cp = new_st;
2952
 
2953
  accept_statement (st);
2954
 
2955
  do
2956
    {
2957
      st = parse_executable (ST_NONE);
2958
      switch (st)
2959
        {
2960
        case ST_NONE:
2961
          unexpected_eof ();
2962
 
2963
        case ST_TYPE_IS:
2964
        case ST_CLASS_IS:
2965
          cp = new_level (gfc_state_stack->head);
2966
          *cp = new_st;
2967
          gfc_clear_new_st ();
2968
 
2969
          accept_statement (st);
2970
          /* Fall through */
2971
 
2972
        case ST_END_SELECT:
2973
          break;
2974
 
2975
        /* Can't have an executable statement because of
2976
           parse_executable().  */
2977
        default:
2978
          unexpected_statement (st);
2979
          break;
2980
        }
2981
    }
2982
  while (st != ST_END_SELECT);
2983
 
2984
done:
2985
  pop_state ();
2986
  accept_statement (st);
2987
  gfc_current_ns = gfc_current_ns->parent;
2988
  select_type_pop ();
2989
}
2990
 
2991
 
2992
/* Given a symbol, make sure it is not an iteration variable for a DO
2993
   statement.  This subroutine is called when the symbol is seen in a
2994
   context that causes it to become redefined.  If the symbol is an
2995
   iterator, we generate an error message and return nonzero.  */
2996
 
2997
int
2998
gfc_check_do_variable (gfc_symtree *st)
2999
{
3000
  gfc_state_data *s;
3001
 
3002
  for (s=gfc_state_stack; s; s = s->previous)
3003
    if (s->do_variable == st)
3004
      {
3005
        gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3006
                      "loop beginning at %L", st->name, &s->head->loc);
3007
        return 1;
3008
      }
3009
 
3010
  return 0;
3011
}
3012
 
3013
 
3014
/* Checks to see if the current statement label closes an enddo.
3015
   Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3016
   an error) if it incorrectly closes an ENDDO.  */
3017
 
3018
static int
3019
check_do_closure (void)
3020
{
3021
  gfc_state_data *p;
3022
 
3023
  if (gfc_statement_label == NULL)
3024
    return 0;
3025
 
3026
  for (p = gfc_state_stack; p; p = p->previous)
3027
    if (p->state == COMP_DO)
3028
      break;
3029
 
3030
  if (p == NULL)
3031
    return 0;            /* No loops to close */
3032
 
3033
  if (p->ext.end_do_label == gfc_statement_label)
3034
    {
3035
      if (p == gfc_state_stack)
3036
        return 1;
3037
 
3038
      gfc_error ("End of nonblock DO statement at %C is within another block");
3039
      return 2;
3040
    }
3041
 
3042
  /* At this point, the label doesn't terminate the innermost loop.
3043
     Make sure it doesn't terminate another one.  */
3044
  for (; p; p = p->previous)
3045
    if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
3046
      {
3047
        gfc_error ("End of nonblock DO statement at %C is interwoven "
3048
                   "with another DO loop");
3049
        return 2;
3050
      }
3051
 
3052
  return 0;
3053
}
3054
 
3055
 
3056
/* Parse a series of contained program units.  */
3057
 
3058
static void parse_progunit (gfc_statement);
3059
 
3060
 
3061
/* Set up the local namespace for a BLOCK construct.  */
3062
 
3063
gfc_namespace*
3064
gfc_build_block_ns (gfc_namespace *parent_ns)
3065
{
3066
  gfc_namespace* my_ns;
3067
 
3068
  my_ns = gfc_get_namespace (parent_ns, 1);
3069
  my_ns->construct_entities = 1;
3070
 
3071
  /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3072
     code generation (so it must not be NULL).
3073
     We set its recursive argument if our container procedure is recursive, so
3074
     that local variables are accordingly placed on the stack when it
3075
     will be necessary.  */
3076
  if (gfc_new_block)
3077
    my_ns->proc_name = gfc_new_block;
3078
  else
3079
    {
3080
      gfc_try t;
3081
 
3082
      gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
3083
      t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3084
                          my_ns->proc_name->name, NULL);
3085
      gcc_assert (t == SUCCESS);
3086
    }
3087
 
3088
  if (parent_ns->proc_name)
3089
    my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3090
 
3091
  return my_ns;
3092
}
3093
 
3094
 
3095
/* Parse a BLOCK construct.  */
3096
 
3097
static void
3098
parse_block_construct (void)
3099
{
3100
  gfc_namespace* my_ns;
3101
  gfc_state_data s;
3102
 
3103
  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3104
 
3105
  my_ns = gfc_build_block_ns (gfc_current_ns);
3106
 
3107
  new_st.op = EXEC_BLOCK;
3108
  new_st.ext.ns = my_ns;
3109
  accept_statement (ST_BLOCK);
3110
 
3111
  push_state (&s, COMP_BLOCK, my_ns->proc_name);
3112
  gfc_current_ns = my_ns;
3113
 
3114
  parse_progunit (ST_NONE);
3115
 
3116
  gfc_current_ns = gfc_current_ns->parent;
3117
  pop_state ();
3118
}
3119
 
3120
 
3121
/* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
3122
   handled inside of parse_executable(), because they aren't really
3123
   loop statements.  */
3124
 
3125
static void
3126
parse_do_block (void)
3127
{
3128
  gfc_statement st;
3129
  gfc_code *top;
3130
  gfc_state_data s;
3131
  gfc_symtree *stree;
3132
 
3133
  s.ext.end_do_label = new_st.label1;
3134
 
3135
  if (new_st.ext.iterator != NULL)
3136
    stree = new_st.ext.iterator->var->symtree;
3137
  else
3138
    stree = NULL;
3139
 
3140
  accept_statement (ST_DO);
3141
 
3142
  top = gfc_state_stack->tail;
3143
  push_state (&s, COMP_DO, gfc_new_block);
3144
 
3145
  s.do_variable = stree;
3146
 
3147
  top->block = new_level (top);
3148
  top->block->op = EXEC_DO;
3149
 
3150
loop:
3151
  st = parse_executable (ST_NONE);
3152
 
3153
  switch (st)
3154
    {
3155
    case ST_NONE:
3156
      unexpected_eof ();
3157
 
3158
    case ST_ENDDO:
3159
      if (s.ext.end_do_label != NULL
3160
          && s.ext.end_do_label != gfc_statement_label)
3161
        gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3162
                       "DO label");
3163
 
3164
      if (gfc_statement_label != NULL)
3165
        {
3166
          new_st.op = EXEC_NOP;
3167
          add_statement ();
3168
        }
3169
      break;
3170
 
3171
    case ST_IMPLIED_ENDDO:
3172
     /* If the do-stmt of this DO construct has a do-construct-name,
3173
        the corresponding end-do must be an end-do-stmt (with a matching
3174
        name, but in that case we must have seen ST_ENDDO first).
3175
        We only complain about this in pedantic mode.  */
3176
     if (gfc_current_block () != NULL)
3177
        gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3178
                       &gfc_current_block()->declared_at);
3179
 
3180
      break;
3181
 
3182
    default:
3183
      unexpected_statement (st);
3184
      goto loop;
3185
    }
3186
 
3187
  pop_state ();
3188
  accept_statement (st);
3189
}
3190
 
3191
 
3192
/* Parse the statements of OpenMP do/parallel do.  */
3193
 
3194
static gfc_statement
3195
parse_omp_do (gfc_statement omp_st)
3196
{
3197
  gfc_statement st;
3198
  gfc_code *cp, *np;
3199
  gfc_state_data s;
3200
 
3201
  accept_statement (omp_st);
3202
 
3203
  cp = gfc_state_stack->tail;
3204
  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3205
  np = new_level (cp);
3206
  np->op = cp->op;
3207
  np->block = NULL;
3208
 
3209
  for (;;)
3210
    {
3211
      st = next_statement ();
3212
      if (st == ST_NONE)
3213
        unexpected_eof ();
3214
      else if (st == ST_DO)
3215
        break;
3216
      else
3217
        unexpected_statement (st);
3218
    }
3219
 
3220
  parse_do_block ();
3221
  if (gfc_statement_label != NULL
3222
      && gfc_state_stack->previous != NULL
3223
      && gfc_state_stack->previous->state == COMP_DO
3224
      && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3225
    {
3226
      /* In
3227
         DO 100 I=1,10
3228
           !$OMP DO
3229
             DO J=1,10
3230
             ...
3231
             100 CONTINUE
3232
         there should be no !$OMP END DO.  */
3233
      pop_state ();
3234
      return ST_IMPLIED_ENDDO;
3235
    }
3236
 
3237
  check_do_closure ();
3238
  pop_state ();
3239
 
3240
  st = next_statement ();
3241
  if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3242
    {
3243
      if (new_st.op == EXEC_OMP_END_NOWAIT)
3244
        cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3245
      else
3246
        gcc_assert (new_st.op == EXEC_NOP);
3247
      gfc_clear_new_st ();
3248
      gfc_commit_symbols ();
3249
      gfc_warning_check ();
3250
      st = next_statement ();
3251
    }
3252
  return st;
3253
}
3254
 
3255
 
3256
/* Parse the statements of OpenMP atomic directive.  */
3257
 
3258
static void
3259
parse_omp_atomic (void)
3260
{
3261
  gfc_statement st;
3262
  gfc_code *cp, *np;
3263
  gfc_state_data s;
3264
 
3265
  accept_statement (ST_OMP_ATOMIC);
3266
 
3267
  cp = gfc_state_stack->tail;
3268
  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3269
  np = new_level (cp);
3270
  np->op = cp->op;
3271
  np->block = NULL;
3272
 
3273
  for (;;)
3274
    {
3275
      st = next_statement ();
3276
      if (st == ST_NONE)
3277
        unexpected_eof ();
3278
      else if (st == ST_ASSIGNMENT)
3279
        break;
3280
      else
3281
        unexpected_statement (st);
3282
    }
3283
 
3284
  accept_statement (st);
3285
 
3286
  pop_state ();
3287
}
3288
 
3289
 
3290
/* Parse the statements of an OpenMP structured block.  */
3291
 
3292
static void
3293
parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3294
{
3295
  gfc_statement st, omp_end_st;
3296
  gfc_code *cp, *np;
3297
  gfc_state_data s;
3298
 
3299
  accept_statement (omp_st);
3300
 
3301
  cp = gfc_state_stack->tail;
3302
  push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3303
  np = new_level (cp);
3304
  np->op = cp->op;
3305
  np->block = NULL;
3306
 
3307
  switch (omp_st)
3308
    {
3309
    case ST_OMP_PARALLEL:
3310
      omp_end_st = ST_OMP_END_PARALLEL;
3311
      break;
3312
    case ST_OMP_PARALLEL_SECTIONS:
3313
      omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3314
      break;
3315
    case ST_OMP_SECTIONS:
3316
      omp_end_st = ST_OMP_END_SECTIONS;
3317
      break;
3318
    case ST_OMP_ORDERED:
3319
      omp_end_st = ST_OMP_END_ORDERED;
3320
      break;
3321
    case ST_OMP_CRITICAL:
3322
      omp_end_st = ST_OMP_END_CRITICAL;
3323
      break;
3324
    case ST_OMP_MASTER:
3325
      omp_end_st = ST_OMP_END_MASTER;
3326
      break;
3327
    case ST_OMP_SINGLE:
3328
      omp_end_st = ST_OMP_END_SINGLE;
3329
      break;
3330
    case ST_OMP_TASK:
3331
      omp_end_st = ST_OMP_END_TASK;
3332
      break;
3333
    case ST_OMP_WORKSHARE:
3334
      omp_end_st = ST_OMP_END_WORKSHARE;
3335
      break;
3336
    case ST_OMP_PARALLEL_WORKSHARE:
3337
      omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3338
      break;
3339
    default:
3340
      gcc_unreachable ();
3341
    }
3342
 
3343
  do
3344
    {
3345
      if (workshare_stmts_only)
3346
        {
3347
          /* Inside of !$omp workshare, only
3348
             scalar assignments
3349
             array assignments
3350
             where statements and constructs
3351
             forall statements and constructs
3352
             !$omp atomic
3353
             !$omp critical
3354
             !$omp parallel
3355
             are allowed.  For !$omp critical these
3356
             restrictions apply recursively.  */
3357
          bool cycle = true;
3358
 
3359
          st = next_statement ();
3360
          for (;;)
3361
            {
3362
              switch (st)
3363
                {
3364
                case ST_NONE:
3365
                  unexpected_eof ();
3366
 
3367
                case ST_ASSIGNMENT:
3368
                case ST_WHERE:
3369
                case ST_FORALL:
3370
                  accept_statement (st);
3371
                  break;
3372
 
3373
                case ST_WHERE_BLOCK:
3374
                  parse_where_block ();
3375
                  break;
3376
 
3377
                case ST_FORALL_BLOCK:
3378
                  parse_forall_block ();
3379
                  break;
3380
 
3381
                case ST_OMP_PARALLEL:
3382
                case ST_OMP_PARALLEL_SECTIONS:
3383
                  parse_omp_structured_block (st, false);
3384
                  break;
3385
 
3386
                case ST_OMP_PARALLEL_WORKSHARE:
3387
                case ST_OMP_CRITICAL:
3388
                  parse_omp_structured_block (st, true);
3389
                  break;
3390
 
3391
                case ST_OMP_PARALLEL_DO:
3392
                  st = parse_omp_do (st);
3393
                  continue;
3394
 
3395
                case ST_OMP_ATOMIC:
3396
                  parse_omp_atomic ();
3397
                  break;
3398
 
3399
                default:
3400
                  cycle = false;
3401
                  break;
3402
                }
3403
 
3404
              if (!cycle)
3405
                break;
3406
 
3407
              st = next_statement ();
3408
            }
3409
        }
3410
      else
3411
        st = parse_executable (ST_NONE);
3412
      if (st == ST_NONE)
3413
        unexpected_eof ();
3414
      else if (st == ST_OMP_SECTION
3415
               && (omp_st == ST_OMP_SECTIONS
3416
                   || omp_st == ST_OMP_PARALLEL_SECTIONS))
3417
        {
3418
          np = new_level (np);
3419
          np->op = cp->op;
3420
          np->block = NULL;
3421
        }
3422
      else if (st != omp_end_st)
3423
        unexpected_statement (st);
3424
    }
3425
  while (st != omp_end_st);
3426
 
3427
  switch (new_st.op)
3428
    {
3429
    case EXEC_OMP_END_NOWAIT:
3430
      cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3431
      break;
3432
    case EXEC_OMP_CRITICAL:
3433
      if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3434
          || (new_st.ext.omp_name != NULL
3435
              && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3436
        gfc_error ("Name after !$omp critical and !$omp end critical does "
3437
                   "not match at %C");
3438
      gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3439
      break;
3440
    case EXEC_OMP_END_SINGLE:
3441
      cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3442
        = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3443
      new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3444
      gfc_free_omp_clauses (new_st.ext.omp_clauses);
3445
      break;
3446
    case EXEC_NOP:
3447
      break;
3448
    default:
3449
      gcc_unreachable ();
3450
    }
3451
 
3452
  gfc_clear_new_st ();
3453
  gfc_commit_symbols ();
3454
  gfc_warning_check ();
3455
  pop_state ();
3456
}
3457
 
3458
 
3459
/* Accept a series of executable statements.  We return the first
3460
   statement that doesn't fit to the caller.  Any block statements are
3461
   passed on to the correct handler, which usually passes the buck
3462
   right back here.  */
3463
 
3464
static gfc_statement
3465
parse_executable (gfc_statement st)
3466
{
3467
  int close_flag;
3468
 
3469
  if (st == ST_NONE)
3470
    st = next_statement ();
3471
 
3472
  for (;;)
3473
    {
3474
      close_flag = check_do_closure ();
3475
      if (close_flag)
3476
        switch (st)
3477
          {
3478
          case ST_GOTO:
3479
          case ST_END_PROGRAM:
3480
          case ST_RETURN:
3481
          case ST_EXIT:
3482
          case ST_END_FUNCTION:
3483
          case ST_CYCLE:
3484
          case ST_PAUSE:
3485
          case ST_STOP:
3486
          case ST_END_SUBROUTINE:
3487
 
3488
          case ST_DO:
3489
          case ST_FORALL:
3490
          case ST_WHERE:
3491
          case ST_SELECT_CASE:
3492
            gfc_error ("%s statement at %C cannot terminate a non-block "
3493
                       "DO loop", gfc_ascii_statement (st));
3494
            break;
3495
 
3496
          default:
3497
            break;
3498
          }
3499
 
3500
      switch (st)
3501
        {
3502
        case ST_NONE:
3503
          unexpected_eof ();
3504
 
3505
        case ST_FORMAT:
3506
        case ST_DATA:
3507
        case ST_ENTRY:
3508
        case_executable:
3509
          accept_statement (st);
3510
          if (close_flag == 1)
3511
            return ST_IMPLIED_ENDDO;
3512
          break;
3513
 
3514
        case ST_BLOCK:
3515
          parse_block_construct ();
3516
          break;
3517
 
3518
        case ST_IF_BLOCK:
3519
          parse_if_block ();
3520
          break;
3521
 
3522
        case ST_SELECT_CASE:
3523
          parse_select_block ();
3524
          break;
3525
 
3526
        case ST_SELECT_TYPE:
3527
          parse_select_type_block();
3528
          break;
3529
 
3530
        case ST_DO:
3531
          parse_do_block ();
3532
          if (check_do_closure () == 1)
3533
            return ST_IMPLIED_ENDDO;
3534
          break;
3535
 
3536
        case ST_WHERE_BLOCK:
3537
          parse_where_block ();
3538
          break;
3539
 
3540
        case ST_FORALL_BLOCK:
3541
          parse_forall_block ();
3542
          break;
3543
 
3544
        case ST_OMP_PARALLEL:
3545
        case ST_OMP_PARALLEL_SECTIONS:
3546
        case ST_OMP_SECTIONS:
3547
        case ST_OMP_ORDERED:
3548
        case ST_OMP_CRITICAL:
3549
        case ST_OMP_MASTER:
3550
        case ST_OMP_SINGLE:
3551
        case ST_OMP_TASK:
3552
          parse_omp_structured_block (st, false);
3553
          break;
3554
 
3555
        case ST_OMP_WORKSHARE:
3556
        case ST_OMP_PARALLEL_WORKSHARE:
3557
          parse_omp_structured_block (st, true);
3558
          break;
3559
 
3560
        case ST_OMP_DO:
3561
        case ST_OMP_PARALLEL_DO:
3562
          st = parse_omp_do (st);
3563
          if (st == ST_IMPLIED_ENDDO)
3564
            return st;
3565
          continue;
3566
 
3567
        case ST_OMP_ATOMIC:
3568
          parse_omp_atomic ();
3569
          break;
3570
 
3571
        default:
3572
          return st;
3573
        }
3574
 
3575
      st = next_statement ();
3576
    }
3577
}
3578
 
3579
 
3580
/* Fix the symbols for sibling functions.  These are incorrectly added to
3581
   the child namespace as the parser didn't know about this procedure.  */
3582
 
3583
static void
3584
gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3585
{
3586
  gfc_namespace *ns;
3587
  gfc_symtree *st;
3588
  gfc_symbol *old_sym;
3589
 
3590
  sym->attr.referenced = 1;
3591
  for (ns = siblings; ns; ns = ns->sibling)
3592
    {
3593
      st = gfc_find_symtree (ns->sym_root, sym->name);
3594
 
3595
      if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3596
        goto fixup_contained;
3597
 
3598
      old_sym = st->n.sym;
3599
      if (old_sym->ns == ns
3600
            && !old_sym->attr.contained
3601
 
3602
            /* By 14.6.1.3, host association should be excluded
3603
               for the following.  */
3604
            && !(old_sym->attr.external
3605
                  || (old_sym->ts.type != BT_UNKNOWN
3606
                        && !old_sym->attr.implicit_type)
3607
                  || old_sym->attr.flavor == FL_PARAMETER
3608
                  || old_sym->attr.use_assoc
3609
                  || old_sym->attr.in_common
3610
                  || old_sym->attr.in_equivalence
3611
                  || old_sym->attr.data
3612
                  || old_sym->attr.dummy
3613
                  || old_sym->attr.result
3614
                  || old_sym->attr.dimension
3615
                  || old_sym->attr.allocatable
3616
                  || old_sym->attr.intrinsic
3617
                  || old_sym->attr.generic
3618
                  || old_sym->attr.flavor == FL_NAMELIST
3619
                  || old_sym->attr.proc == PROC_ST_FUNCTION))
3620
        {
3621
          /* Replace it with the symbol from the parent namespace.  */
3622
          st->n.sym = sym;
3623
          sym->refs++;
3624
 
3625
          /* Free the old (local) symbol.  */
3626
          old_sym->refs--;
3627
          if (old_sym->refs == 0)
3628
            gfc_free_symbol (old_sym);
3629
        }
3630
 
3631
fixup_contained:
3632
      /* Do the same for any contained procedures.  */
3633
      gfc_fixup_sibling_symbols (sym, ns->contained);
3634
    }
3635
}
3636
 
3637
static void
3638
parse_contained (int module)
3639
{
3640
  gfc_namespace *ns, *parent_ns, *tmp;
3641
  gfc_state_data s1, s2;
3642
  gfc_statement st;
3643
  gfc_symbol *sym;
3644
  gfc_entry_list *el;
3645
  int contains_statements = 0;
3646
  int seen_error = 0;
3647
 
3648
  push_state (&s1, COMP_CONTAINS, NULL);
3649
  parent_ns = gfc_current_ns;
3650
 
3651
  do
3652
    {
3653
      gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3654
 
3655
      gfc_current_ns->sibling = parent_ns->contained;
3656
      parent_ns->contained = gfc_current_ns;
3657
 
3658
 next:
3659
      /* Process the next available statement.  We come here if we got an error
3660
         and rejected the last statement.  */
3661
      st = next_statement ();
3662
 
3663
      switch (st)
3664
        {
3665
        case ST_NONE:
3666
          unexpected_eof ();
3667
 
3668
        case ST_FUNCTION:
3669
        case ST_SUBROUTINE:
3670
          contains_statements = 1;
3671
          accept_statement (st);
3672
 
3673
          push_state (&s2,
3674
                      (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3675
                      gfc_new_block);
3676
 
3677
          /* For internal procedures, create/update the symbol in the
3678
             parent namespace.  */
3679
 
3680
          if (!module)
3681
            {
3682
              if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3683
                gfc_error ("Contained procedure '%s' at %C is already "
3684
                           "ambiguous", gfc_new_block->name);
3685
              else
3686
                {
3687
                  if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3688
                                         &gfc_new_block->declared_at) ==
3689
                      SUCCESS)
3690
                    {
3691
                      if (st == ST_FUNCTION)
3692
                        gfc_add_function (&sym->attr, sym->name,
3693
                                          &gfc_new_block->declared_at);
3694
                      else
3695
                        gfc_add_subroutine (&sym->attr, sym->name,
3696
                                            &gfc_new_block->declared_at);
3697
                    }
3698
                }
3699
 
3700
              gfc_commit_symbols ();
3701
            }
3702
          else
3703
            sym = gfc_new_block;
3704
 
3705
          /* Mark this as a contained function, so it isn't replaced
3706
             by other module functions.  */
3707
          sym->attr.contained = 1;
3708
          sym->attr.referenced = 1;
3709
 
3710
          parse_progunit (ST_NONE);
3711
 
3712
          /* Fix up any sibling functions that refer to this one.  */
3713
          gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3714
          /* Or refer to any of its alternate entry points.  */
3715
          for (el = gfc_current_ns->entries; el; el = el->next)
3716
            gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3717
 
3718
          gfc_current_ns->code = s2.head;
3719
          gfc_current_ns = parent_ns;
3720
 
3721
          pop_state ();
3722
          break;
3723
 
3724
        /* These statements are associated with the end of the host unit.  */
3725
        case ST_END_FUNCTION:
3726
        case ST_END_MODULE:
3727
        case ST_END_PROGRAM:
3728
        case ST_END_SUBROUTINE:
3729
          accept_statement (st);
3730
          break;
3731
 
3732
        default:
3733
          gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3734
                     gfc_ascii_statement (st));
3735
          reject_statement ();
3736
          seen_error = 1;
3737
          goto next;
3738
          break;
3739
        }
3740
    }
3741
  while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3742
         && st != ST_END_MODULE && st != ST_END_PROGRAM);
3743
 
3744
  /* The first namespace in the list is guaranteed to not have
3745
     anything (worthwhile) in it.  */
3746
  tmp = gfc_current_ns;
3747
  gfc_current_ns = parent_ns;
3748
  if (seen_error && tmp->refs > 1)
3749
    gfc_free_namespace (tmp);
3750
 
3751
  ns = gfc_current_ns->contained;
3752
  gfc_current_ns->contained = ns->sibling;
3753
  gfc_free_namespace (ns);
3754
 
3755
  pop_state ();
3756
  if (!contains_statements)
3757
    gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3758
                    "FUNCTION or SUBROUTINE statement at %C");
3759
}
3760
 
3761
 
3762
/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
3763
 
3764
static void
3765
parse_progunit (gfc_statement st)
3766
{
3767
  gfc_state_data *p;
3768
  int n;
3769
 
3770
  st = parse_spec (st);
3771
  switch (st)
3772
    {
3773
    case ST_NONE:
3774
      unexpected_eof ();
3775
 
3776
    case ST_CONTAINS:
3777
      /* This is not allowed within BLOCK!  */
3778
      if (gfc_current_state () != COMP_BLOCK)
3779
        goto contains;
3780
      break;
3781
 
3782
    case_end:
3783
      accept_statement (st);
3784
      goto done;
3785
 
3786
    default:
3787
      break;
3788
    }
3789
 
3790
  if (gfc_current_state () == COMP_FUNCTION)
3791
    gfc_check_function_type (gfc_current_ns);
3792
 
3793
loop:
3794
  for (;;)
3795
    {
3796
      st = parse_executable (st);
3797
 
3798
      switch (st)
3799
        {
3800
        case ST_NONE:
3801
          unexpected_eof ();
3802
 
3803
        case ST_CONTAINS:
3804
          /* This is not allowed within BLOCK!  */
3805
          if (gfc_current_state () != COMP_BLOCK)
3806
            goto contains;
3807
          break;
3808
 
3809
        case_end:
3810
          accept_statement (st);
3811
          goto done;
3812
 
3813
        default:
3814
          break;
3815
        }
3816
 
3817
      unexpected_statement (st);
3818
      reject_statement ();
3819
      st = next_statement ();
3820
    }
3821
 
3822
contains:
3823
  n = 0;
3824
 
3825
  for (p = gfc_state_stack; p; p = p->previous)
3826
    if (p->state == COMP_CONTAINS)
3827
      n++;
3828
 
3829
  if (gfc_find_state (COMP_MODULE) == SUCCESS)
3830
    n--;
3831
 
3832
  if (n > 0)
3833
    {
3834
      gfc_error ("CONTAINS statement at %C is already in a contained "
3835
                 "program unit");
3836 378 julius
      reject_statement ();
3837 285 jeremybenn
      st = next_statement ();
3838
      goto loop;
3839
    }
3840
 
3841
  parse_contained (0);
3842
 
3843
done:
3844
  gfc_current_ns->code = gfc_state_stack->head;
3845
}
3846
 
3847
 
3848
/* Come here to complain about a global symbol already in use as
3849
   something else.  */
3850
 
3851
void
3852
gfc_global_used (gfc_gsymbol *sym, locus *where)
3853
{
3854
  const char *name;
3855
 
3856
  if (where == NULL)
3857
    where = &gfc_current_locus;
3858
 
3859
  switch(sym->type)
3860
    {
3861
    case GSYM_PROGRAM:
3862
      name = "PROGRAM";
3863
      break;
3864
    case GSYM_FUNCTION:
3865
      name = "FUNCTION";
3866
      break;
3867
    case GSYM_SUBROUTINE:
3868
      name = "SUBROUTINE";
3869
      break;
3870
    case GSYM_COMMON:
3871
      name = "COMMON";
3872
      break;
3873
    case GSYM_BLOCK_DATA:
3874
      name = "BLOCK DATA";
3875
      break;
3876
    case GSYM_MODULE:
3877
      name = "MODULE";
3878
      break;
3879
    default:
3880
      gfc_internal_error ("gfc_global_used(): Bad type");
3881
      name = NULL;
3882
    }
3883
 
3884
  gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3885
              sym->name, where, name, &sym->where);
3886
}
3887
 
3888
 
3889
/* Parse a block data program unit.  */
3890
 
3891
static void
3892
parse_block_data (void)
3893
{
3894
  gfc_statement st;
3895
  static locus blank_locus;
3896
  static int blank_block=0;
3897
  gfc_gsymbol *s;
3898
 
3899
  gfc_current_ns->proc_name = gfc_new_block;
3900
  gfc_current_ns->is_block_data = 1;
3901
 
3902
  if (gfc_new_block == NULL)
3903
    {
3904
      if (blank_block)
3905
       gfc_error ("Blank BLOCK DATA at %C conflicts with "
3906
                  "prior BLOCK DATA at %L", &blank_locus);
3907
      else
3908
       {
3909
         blank_block = 1;
3910
         blank_locus = gfc_current_locus;
3911
       }
3912
    }
3913
  else
3914
    {
3915
      s = gfc_get_gsymbol (gfc_new_block->name);
3916
      if (s->defined
3917
          || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3918
       gfc_global_used(s, NULL);
3919
      else
3920
       {
3921
         s->type = GSYM_BLOCK_DATA;
3922
         s->where = gfc_current_locus;
3923
         s->defined = 1;
3924
       }
3925
    }
3926
 
3927
  st = parse_spec (ST_NONE);
3928
 
3929
  while (st != ST_END_BLOCK_DATA)
3930
    {
3931
      gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3932
                 gfc_ascii_statement (st));
3933
      reject_statement ();
3934
      st = next_statement ();
3935
    }
3936
}
3937
 
3938
 
3939
/* Parse a module subprogram.  */
3940
 
3941
static void
3942
parse_module (void)
3943
{
3944
  gfc_statement st;
3945
  gfc_gsymbol *s;
3946
 
3947
  s = gfc_get_gsymbol (gfc_new_block->name);
3948
  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3949
    gfc_global_used(s, NULL);
3950
  else
3951
    {
3952
      s->type = GSYM_MODULE;
3953
      s->where = gfc_current_locus;
3954
      s->defined = 1;
3955
    }
3956
 
3957
  st = parse_spec (ST_NONE);
3958
 
3959
loop:
3960
  switch (st)
3961
    {
3962
    case ST_NONE:
3963
      unexpected_eof ();
3964
 
3965
    case ST_CONTAINS:
3966
      parse_contained (1);
3967
      break;
3968
 
3969
    case ST_END_MODULE:
3970
      accept_statement (st);
3971
      break;
3972
 
3973
    default:
3974
      gfc_error ("Unexpected %s statement in MODULE at %C",
3975
                 gfc_ascii_statement (st));
3976
 
3977
      reject_statement ();
3978
      st = next_statement ();
3979
      goto loop;
3980
    }
3981
 
3982
  s->ns = gfc_current_ns;
3983
}
3984
 
3985
 
3986
/* Add a procedure name to the global symbol table.  */
3987
 
3988
static void
3989
add_global_procedure (int sub)
3990
{
3991
  gfc_gsymbol *s;
3992
 
3993
  s = gfc_get_gsymbol(gfc_new_block->name);
3994
 
3995
  if (s->defined
3996
      || (s->type != GSYM_UNKNOWN
3997
          && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3998
    gfc_global_used(s, NULL);
3999
  else
4000
    {
4001
      s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4002
      s->where = gfc_current_locus;
4003
      s->defined = 1;
4004
      s->ns = gfc_current_ns;
4005
    }
4006
}
4007
 
4008
 
4009
/* Add a program to the global symbol table.  */
4010
 
4011
static void
4012
add_global_program (void)
4013
{
4014
  gfc_gsymbol *s;
4015
 
4016
  if (gfc_new_block == NULL)
4017
    return;
4018
  s = gfc_get_gsymbol (gfc_new_block->name);
4019
 
4020
  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4021
    gfc_global_used(s, NULL);
4022
  else
4023
    {
4024
      s->type = GSYM_PROGRAM;
4025
      s->where = gfc_current_locus;
4026
      s->defined = 1;
4027
      s->ns = gfc_current_ns;
4028
    }
4029
}
4030
 
4031
 
4032
/* Resolve all the program units when whole file scope option
4033
   is active. */
4034
static void
4035
resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4036
{
4037
  gfc_free_dt_list ();
4038
  gfc_current_ns = gfc_global_ns_list;
4039
  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4040
    {
4041
      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4042
      gfc_resolve (gfc_current_ns);
4043
      gfc_current_ns->derived_types = gfc_derived_types;
4044
      gfc_derived_types = NULL;
4045
    }
4046
}
4047
 
4048
 
4049
static void
4050
clean_up_modules (gfc_gsymbol *gsym)
4051
{
4052
  if (gsym == NULL)
4053
    return;
4054
 
4055
  clean_up_modules (gsym->left);
4056
  clean_up_modules (gsym->right);
4057
 
4058
  if (gsym->type != GSYM_MODULE || !gsym->ns)
4059
    return;
4060
 
4061
  gfc_current_ns = gsym->ns;
4062
  gfc_derived_types = gfc_current_ns->derived_types;
4063
  gfc_done_2 ();
4064
  gsym->ns = NULL;
4065
  return;
4066
}
4067
 
4068
 
4069
/* Translate all the program units when whole file scope option
4070
   is active. This could be in a different order to resolution if
4071
   there are forward references in the file.  */
4072
static void
4073
translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4074
{
4075
  int errors;
4076
 
4077
  gfc_current_ns = gfc_global_ns_list;
4078
  gfc_get_errors (NULL, &errors);
4079
 
4080
  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4081
    {
4082
      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4083
      gfc_derived_types = gfc_current_ns->derived_types;
4084
      gfc_generate_code (gfc_current_ns);
4085
      gfc_current_ns->translated = 1;
4086
    }
4087
 
4088
  /* Clean up all the namespaces after translation.  */
4089
  gfc_current_ns = gfc_global_ns_list;
4090
  for (;gfc_current_ns;)
4091
    {
4092
      gfc_namespace *ns = gfc_current_ns->sibling;
4093
      gfc_derived_types = gfc_current_ns->derived_types;
4094
      gfc_done_2 ();
4095
      gfc_current_ns = ns;
4096
    }
4097
 
4098
  clean_up_modules (gfc_gsym_root);
4099
}
4100
 
4101
 
4102
/* Top level parser.  */
4103
 
4104
gfc_try
4105
gfc_parse_file (void)
4106
{
4107
  int seen_program, errors_before, errors;
4108
  gfc_state_data top, s;
4109
  gfc_statement st;
4110
  locus prog_locus;
4111
  gfc_namespace *next;
4112
 
4113
  gfc_start_source_files ();
4114
 
4115
  top.state = COMP_NONE;
4116
  top.sym = NULL;
4117
  top.previous = NULL;
4118
  top.head = top.tail = NULL;
4119
  top.do_variable = NULL;
4120
 
4121
  gfc_state_stack = &top;
4122
 
4123
  gfc_clear_new_st ();
4124
 
4125
  gfc_statement_label = NULL;
4126
 
4127
  if (setjmp (eof_buf))
4128
    return FAILURE;     /* Come here on unexpected EOF */
4129
 
4130
  /* Prepare the global namespace that will contain the
4131
     program units.  */
4132
  gfc_global_ns_list = next = NULL;
4133
 
4134
  seen_program = 0;
4135
 
4136
  /* Exit early for empty files.  */
4137
  if (gfc_at_eof ())
4138
    goto done;
4139
 
4140
loop:
4141
  gfc_init_2 ();
4142
  st = next_statement ();
4143
  switch (st)
4144
    {
4145
    case ST_NONE:
4146
      gfc_done_2 ();
4147
      goto done;
4148
 
4149
    case ST_PROGRAM:
4150
      if (seen_program)
4151
        goto duplicate_main;
4152
      seen_program = 1;
4153
      prog_locus = gfc_current_locus;
4154
 
4155
      push_state (&s, COMP_PROGRAM, gfc_new_block);
4156
      main_program_symbol(gfc_current_ns, gfc_new_block->name);
4157
      accept_statement (st);
4158
      add_global_program ();
4159
      parse_progunit (ST_NONE);
4160
      if (gfc_option.flag_whole_file)
4161
        goto prog_units;
4162
      break;
4163
 
4164
    case ST_SUBROUTINE:
4165
      add_global_procedure (1);
4166
      push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4167
      accept_statement (st);
4168
      parse_progunit (ST_NONE);
4169
      if (gfc_option.flag_whole_file)
4170
        goto prog_units;
4171
      break;
4172
 
4173
    case ST_FUNCTION:
4174
      add_global_procedure (0);
4175
      push_state (&s, COMP_FUNCTION, gfc_new_block);
4176
      accept_statement (st);
4177
      parse_progunit (ST_NONE);
4178
      if (gfc_option.flag_whole_file)
4179
        goto prog_units;
4180
      break;
4181
 
4182
    case ST_BLOCK_DATA:
4183
      push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4184
      accept_statement (st);
4185
      parse_block_data ();
4186
      break;
4187
 
4188
    case ST_MODULE:
4189
      push_state (&s, COMP_MODULE, gfc_new_block);
4190
      accept_statement (st);
4191
 
4192
      gfc_get_errors (NULL, &errors_before);
4193
      parse_module ();
4194
      break;
4195
 
4196
    /* Anything else starts a nameless main program block.  */
4197
    default:
4198
      if (seen_program)
4199
        goto duplicate_main;
4200
      seen_program = 1;
4201
      prog_locus = gfc_current_locus;
4202
 
4203
      push_state (&s, COMP_PROGRAM, gfc_new_block);
4204
      main_program_symbol (gfc_current_ns, "MAIN__");
4205
      parse_progunit (st);
4206
      if (gfc_option.flag_whole_file)
4207
        goto prog_units;
4208
      break;
4209
    }
4210
 
4211
  /* Handle the non-program units.  */
4212
  gfc_current_ns->code = s.head;
4213
 
4214
  gfc_resolve (gfc_current_ns);
4215
 
4216
  /* Dump the parse tree if requested.  */
4217
  if (gfc_option.dump_parse_tree)
4218
    gfc_dump_parse_tree (gfc_current_ns, stdout);
4219
 
4220
  gfc_get_errors (NULL, &errors);
4221
  if (s.state == COMP_MODULE)
4222
    {
4223
      gfc_dump_module (s.sym->name, errors_before == errors);
4224
      if (errors == 0)
4225
        gfc_generate_module_code (gfc_current_ns);
4226
      pop_state ();
4227
      if (!gfc_option.flag_whole_file)
4228
        gfc_done_2 ();
4229
      else
4230
        {
4231
          gfc_current_ns->derived_types = gfc_derived_types;
4232
          gfc_derived_types = NULL;
4233
          gfc_current_ns = NULL;
4234
        }
4235
    }
4236
  else
4237
    {
4238
      if (errors == 0)
4239
        gfc_generate_code (gfc_current_ns);
4240
      pop_state ();
4241
      gfc_done_2 ();
4242
    }
4243
 
4244
  goto loop;
4245
 
4246
prog_units:
4247
  /* The main program and non-contained procedures are put
4248
     in the global namespace list, so that they can be processed
4249
     later and all their interfaces resolved.  */
4250
  gfc_current_ns->code = s.head;
4251
  if (next)
4252
    next->sibling = gfc_current_ns;
4253
  else
4254
    gfc_global_ns_list = gfc_current_ns;
4255
 
4256
  next = gfc_current_ns;
4257
 
4258
  pop_state ();
4259
  goto loop;
4260
 
4261
  done:
4262
 
4263
  if (!gfc_option.flag_whole_file)
4264
    goto termination;
4265
 
4266
  /* Do the resolution.  */
4267
  resolve_all_program_units (gfc_global_ns_list);
4268
 
4269
  /* Do the parse tree dump.  */
4270
  gfc_current_ns
4271
        = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
4272
 
4273
  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4274
    {
4275
      gfc_dump_parse_tree (gfc_current_ns, stdout);
4276
      fputs ("------------------------------------------\n\n", stdout);
4277
    }
4278
 
4279
  /* Do the translation.  */
4280
  translate_all_program_units (gfc_global_ns_list);
4281
 
4282
termination:
4283
 
4284
  gfc_end_source_files ();
4285
  return SUCCESS;
4286
 
4287
duplicate_main:
4288
  /* If we see a duplicate main program, shut down.  If the second
4289
     instance is an implied main program, i.e. data decls or executable
4290
     statements, we're in for lots of errors.  */
4291
  gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4292
  reject_statement ();
4293
  gfc_done_2 ();
4294
  return SUCCESS;
4295
}

powered by: WebSVN 2.1.0

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