OSDN Git Service

2007-02-21 Bernhard Fischer <aldot@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / parse.c
1 /* Main parser.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
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
30 /* Current statement label.  Zero means no statement label.  Because new_st
31    can get wiped during statement matching, we have to keep it separate.  */
32
33 gfc_st_label *gfc_statement_label;
34
35 static locus label_locus;
36 static jmp_buf eof_buf;
37
38 gfc_state_data *gfc_state_stack;
39
40 /* TODO: Re-order functions to kill these forward decls.  */
41 static void check_statement_label (gfc_statement);
42 static void undo_new_statement (void);
43 static void reject_statement (void);
44
45 /* A sort of half-matching function.  We try to match the word on the
46    input with the passed string.  If this succeeds, we call the
47    keyword-dependent matching function that will match the rest of the
48    statement.  For single keywords, the matching subroutine is
49    gfc_match_eos().  */
50
51 static match
52 match_word (const char *str, match (*subr) (void), locus *old_locus)
53 {
54   match m;
55
56   if (str != NULL)
57     {
58       m = gfc_match (str);
59       if (m != MATCH_YES)
60         return m;
61     }
62
63   m = (*subr) ();
64
65   if (m != MATCH_YES)
66     {
67       gfc_current_locus = *old_locus;
68       reject_statement ();
69     }
70
71   return m;
72 }
73
74
75 /* Figure out what the next statement is, (mostly) regardless of
76    proper ordering.  The do...while(0) is there to prevent if/else
77    ambiguity.  */
78
79 #define match(keyword, subr, st)                                \
80     do {                                                        \
81       if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
82         return st;                                              \
83       else                                                      \
84         undo_new_statement ();                            \
85     } while (0);
86
87 static gfc_statement
88 decode_statement (void)
89 {
90   gfc_statement st;
91   locus old_locus;
92   match m;
93   int c;
94
95 #ifdef GFC_DEBUG
96   gfc_symbol_state ();
97 #endif
98
99   gfc_clear_error ();   /* Clear any pending errors.  */
100   gfc_clear_warning (); /* Clear any pending warnings.  */
101
102   if (gfc_match_eos () == MATCH_YES)
103     return ST_NONE;
104
105   old_locus = gfc_current_locus;
106
107   /* Try matching a data declaration or function declaration. The
108       input "REALFUNCTIONA(N)" can mean several things in different
109       contexts, so it (and its relatives) get special treatment.  */
110
111   if (gfc_current_state () == COMP_NONE
112       || gfc_current_state () == COMP_INTERFACE
113       || gfc_current_state () == COMP_CONTAINS)
114     {
115       m = gfc_match_function_decl ();
116       if (m == MATCH_YES)
117         return ST_FUNCTION;
118       else if (m == MATCH_ERROR)
119         reject_statement ();
120
121       gfc_undo_symbols ();
122       gfc_current_locus = old_locus;
123     }
124
125   /* Match statements whose error messages are meant to be overwritten
126      by something better.  */
127
128   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
129   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
130   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
131
132   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
133   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
134
135   /* Try to match a subroutine statement, which has the same optional
136      prefixes that functions can have.  */
137
138   if (gfc_match_subroutine () == MATCH_YES)
139     return ST_SUBROUTINE;
140   gfc_undo_symbols ();
141   gfc_current_locus = old_locus;
142
143   /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
144      might begin with a block label.  The match functions for these
145      statements are unusual in that their keyword is not seen before
146      the matcher is called.  */
147
148   if (gfc_match_if (&st) == MATCH_YES)
149     return st;
150   gfc_undo_symbols ();
151   gfc_current_locus = old_locus;
152
153   if (gfc_match_where (&st) == MATCH_YES)
154     return st;
155   gfc_undo_symbols ();
156   gfc_current_locus = old_locus;
157
158   if (gfc_match_forall (&st) == MATCH_YES)
159     return st;
160   gfc_undo_symbols ();
161   gfc_current_locus = old_locus;
162
163   match (NULL, gfc_match_do, ST_DO);
164   match (NULL, gfc_match_select, ST_SELECT_CASE);
165
166   /* General statement matching: Instead of testing every possible
167      statement, we eliminate most possibilities by peeking at the
168      first character.  */
169
170   c = gfc_peek_char ();
171
172   switch (c)
173     {
174     case 'a':
175       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
176       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
177       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
178       break;
179
180     case 'b':
181       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
182       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
183       break;
184
185     case 'c':
186       match ("call", gfc_match_call, ST_CALL);
187       match ("close", gfc_match_close, ST_CLOSE);
188       match ("continue", gfc_match_continue, ST_CONTINUE);
189       match ("cycle", gfc_match_cycle, ST_CYCLE);
190       match ("case", gfc_match_case, ST_CASE);
191       match ("common", gfc_match_common, ST_COMMON);
192       match ("contains", gfc_match_eos, ST_CONTAINS);
193       break;
194
195     case 'd':
196       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
197       match ("data", gfc_match_data, ST_DATA);
198       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
199       break;
200
201     case 'e':
202       match ("end file", gfc_match_endfile, ST_END_FILE);
203       match ("exit", gfc_match_exit, ST_EXIT);
204       match ("else", gfc_match_else, ST_ELSE);
205       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
206       match ("else if", gfc_match_elseif, ST_ELSEIF);
207       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
208
209       if (gfc_match_end (&st) == MATCH_YES)
210         return st;
211
212       match ("entry% ", gfc_match_entry, ST_ENTRY);
213       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
214       match ("external", gfc_match_external, ST_ATTR_DECL);
215       break;
216
217     case 'f':
218       match ("flush", gfc_match_flush, ST_FLUSH);
219       match ("format", gfc_match_format, ST_FORMAT);
220       break;
221
222     case 'g':
223       match ("go to", gfc_match_goto, ST_GOTO);
224       break;
225
226     case 'i':
227       match ("inquire", gfc_match_inquire, ST_INQUIRE);
228       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
229       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
230       match ("import", gfc_match_import, ST_IMPORT);
231       match ("interface", gfc_match_interface, ST_INTERFACE);
232       match ("intent", gfc_match_intent, ST_ATTR_DECL);
233       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
234       break;
235
236     case 'm':
237       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
238       match ("module", gfc_match_module, ST_MODULE);
239       break;
240
241     case 'n':
242       match ("nullify", gfc_match_nullify, ST_NULLIFY);
243       match ("namelist", gfc_match_namelist, ST_NAMELIST);
244       break;
245
246     case 'o':
247       match ("open", gfc_match_open, ST_OPEN);
248       match ("optional", gfc_match_optional, ST_ATTR_DECL);
249       break;
250
251     case 'p':
252       match ("print", gfc_match_print, ST_WRITE);
253       match ("parameter", gfc_match_parameter, ST_PARAMETER);
254       match ("pause", gfc_match_pause, ST_PAUSE);
255       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
256       if (gfc_match_private (&st) == MATCH_YES)
257         return st;
258       match ("program", gfc_match_program, ST_PROGRAM);
259       if (gfc_match_public (&st) == MATCH_YES)
260         return st;
261       match ("protected", gfc_match_protected, ST_ATTR_DECL);
262       break;
263
264     case 'r':
265       match ("read", gfc_match_read, ST_READ);
266       match ("return", gfc_match_return, ST_RETURN);
267       match ("rewind", gfc_match_rewind, ST_REWIND);
268       break;
269
270     case 's':
271       match ("sequence", gfc_match_eos, ST_SEQUENCE);
272       match ("stop", gfc_match_stop, ST_STOP);
273       match ("save", gfc_match_save, ST_ATTR_DECL);
274       break;
275
276     case 't':
277       match ("target", gfc_match_target, ST_ATTR_DECL);
278       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
279       break;
280
281     case 'u':
282       match ("use", gfc_match_use, ST_USE);
283       break;
284
285     case 'v':
286       match ("value", gfc_match_value, ST_ATTR_DECL);
287       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
288       break;
289
290     case 'w':
291       match ("write", gfc_match_write, ST_WRITE);
292       break;
293     }
294
295   /* All else has failed, so give up.  See if any of the matchers has
296      stored an error message of some sort.  */
297
298   if (gfc_error_check () == 0)
299     gfc_error_now ("Unclassifiable statement at %C");
300
301   reject_statement ();
302
303   gfc_error_recovery ();
304
305   return ST_NONE;
306 }
307
308 static gfc_statement
309 decode_omp_directive (void)
310 {
311   locus old_locus;
312   int c;
313
314 #ifdef GFC_DEBUG
315   gfc_symbol_state ();
316 #endif
317
318   gfc_clear_error ();   /* Clear any pending errors.  */
319   gfc_clear_warning (); /* Clear any pending warnings.  */
320
321   if (gfc_pure (NULL))
322     {
323       gfc_error_now ("OpenMP directives at %C may not appear in PURE "
324                      "or ELEMENTAL procedures");
325       gfc_error_recovery ();
326       return ST_NONE;
327     }
328
329   old_locus = gfc_current_locus;
330
331   /* General OpenMP directive matching: Instead of testing every possible
332      statement, we eliminate most possibilities by peeking at the
333      first character.  */
334
335   c = gfc_peek_char ();
336
337   switch (c)
338     {
339     case 'a':
340       match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
341       break;
342     case 'b':
343       match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
344       break;
345     case 'c':
346       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
347       break;
348     case 'd':
349       match ("do", gfc_match_omp_do, ST_OMP_DO);
350       break;
351     case 'e':
352       match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
353       match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
354       match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
355       match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
356       match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
357       match ("end parallel sections", gfc_match_omp_eos,
358              ST_OMP_END_PARALLEL_SECTIONS);
359       match ("end parallel workshare", gfc_match_omp_eos,
360              ST_OMP_END_PARALLEL_WORKSHARE);
361       match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
362       match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
363       match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
364       match ("end workshare", gfc_match_omp_end_nowait,
365              ST_OMP_END_WORKSHARE);
366       break;
367     case 'f':
368       match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
369       break;
370     case 'm':
371       match ("master", gfc_match_omp_master, ST_OMP_MASTER);
372       break;
373     case 'o':
374       match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
375       break;
376     case 'p':
377       match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
378       match ("parallel sections", gfc_match_omp_parallel_sections,
379              ST_OMP_PARALLEL_SECTIONS);
380       match ("parallel workshare", gfc_match_omp_parallel_workshare,
381              ST_OMP_PARALLEL_WORKSHARE);
382       match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
383       break;
384     case 's':
385       match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
386       match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
387       match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
388       break;
389     case 't':
390       match ("threadprivate", gfc_match_omp_threadprivate,
391              ST_OMP_THREADPRIVATE);
392     case 'w':
393       match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
394       break;
395     }
396
397   /* All else has failed, so give up.  See if any of the matchers has
398      stored an error message of some sort.  */
399
400   if (gfc_error_check () == 0)
401     gfc_error_now ("Unclassifiable OpenMP directive at %C");
402
403   reject_statement ();
404
405   gfc_error_recovery ();
406
407   return ST_NONE;
408 }
409
410 #undef match
411
412
413 /* Get the next statement in free form source.  */
414
415 static gfc_statement
416 next_free (void)
417 {
418   match m;
419   int c, d, cnt, at_bol;
420
421   at_bol = gfc_at_bol ();
422   gfc_gobble_whitespace ();
423
424   c = gfc_peek_char ();
425
426   if (ISDIGIT (c))
427     {
428       /* Found a statement label?  */
429       m = gfc_match_st_label (&gfc_statement_label);
430
431       d = gfc_peek_char ();
432       if (m != MATCH_YES || !gfc_is_whitespace (d))
433         {
434           gfc_match_small_literal_int (&c, &cnt);
435
436           if (cnt > 5)
437             gfc_error_now ("Too many digits in statement label at %C");
438
439           if (c == 0)
440             gfc_error_now ("Zero is not a valid statement label at %C");
441
442           do
443             c = gfc_next_char ();
444           while (ISDIGIT(c));
445
446           if (!gfc_is_whitespace (c))
447             gfc_error_now ("Non-numeric character in statement label at %C");
448
449           return ST_NONE;
450         }
451       else
452         {
453           label_locus = gfc_current_locus;
454
455           gfc_gobble_whitespace ();
456
457           if (at_bol && gfc_peek_char () == ';')
458             {
459               gfc_error_now ("Semicolon at %C needs to be preceded by "
460                              "statement");
461               gfc_next_char (); /* Eat up the semicolon.  */
462               return ST_NONE;
463             }
464
465           if (gfc_match_eos () == MATCH_YES)
466             {
467               gfc_warning_now ("Ignoring statement label in empty statement "
468                                "at %C");
469               gfc_free_st_label (gfc_statement_label);
470               gfc_statement_label = NULL;
471               return ST_NONE;
472             }
473         }
474     }
475   else if (c == '!')
476     {
477       /* Comments have already been skipped by the time we get here,
478          except for OpenMP directives.  */
479       if (gfc_option.flag_openmp)
480         {
481           int i;
482
483           c = gfc_next_char ();
484           for (i = 0; i < 5; i++, c = gfc_next_char ())
485             gcc_assert (c == "!$omp"[i]);
486
487           gcc_assert (c == ' ');
488           gfc_gobble_whitespace ();
489           return decode_omp_directive ();
490         }
491     }
492
493   if (at_bol && c == ';')
494     {
495       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
496       gfc_next_char (); /* Eat up the semicolon.  */
497       return ST_NONE;
498     }
499
500   return decode_statement ();
501 }
502
503
504 /* Get the next statement in fixed-form source.  */
505
506 static gfc_statement
507 next_fixed (void)
508 {
509   int label, digit_flag, i;
510   locus loc;
511   char c;
512
513   if (!gfc_at_bol ())
514     return decode_statement ();
515
516   /* Skip past the current label field, parsing a statement label if
517      one is there.  This is a weird number parser, since the number is
518      contained within five columns and can have any kind of embedded
519      spaces.  We also check for characters that make the rest of the
520      line a comment.  */
521
522   label = 0;
523   digit_flag = 0;
524
525   for (i = 0; i < 5; i++)
526     {
527       c = gfc_next_char_literal (0);
528
529       switch (c)
530         {
531         case ' ':
532           break;
533
534         case '0':
535         case '1':
536         case '2':
537         case '3':
538         case '4':
539         case '5':
540         case '6':
541         case '7':
542         case '8':
543         case '9':
544           label = label * 10 + c - '0';
545           label_locus = gfc_current_locus;
546           digit_flag = 1;
547           break;
548
549           /* Comments have already been skipped by the time we get
550              here, except for OpenMP directives.  */
551         case '*':
552           if (gfc_option.flag_openmp)
553             {
554               for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
555                 gcc_assert (TOLOWER (c) == "*$omp"[i]);
556
557               if (c != ' ' && c != '0')
558                 {
559                   gfc_buffer_error (0);
560                   gfc_error ("Bad continuation line at %C");
561                   return ST_NONE;
562                 }
563
564               return decode_omp_directive ();
565             }
566           /* FALLTHROUGH */
567
568           /* Comments have already been skipped by the time we get
569              here so don't bother checking for them.  */
570
571         default:
572           gfc_buffer_error (0);
573           gfc_error ("Non-numeric character in statement label at %C");
574           return ST_NONE;
575         }
576     }
577
578   if (digit_flag)
579     {
580       if (label == 0)
581         gfc_warning_now ("Zero is not a valid statement label at %C");
582       else
583         {
584           /* We've found a valid statement label.  */
585           gfc_statement_label = gfc_get_st_label (label);
586         }
587     }
588
589   /* Since this line starts a statement, it cannot be a continuation
590      of a previous statement.  If we see something here besides a
591      space or zero, it must be a bad continuation line.  */
592
593   c = gfc_next_char_literal (0);
594   if (c == '\n')
595     goto blank_line;
596
597   if (c != ' ' && c != '0')
598     {
599       gfc_buffer_error (0);
600       gfc_error ("Bad continuation line at %C");
601       return ST_NONE;
602     }
603
604   /* Now that we've taken care of the statement label columns, we have
605      to make sure that the first nonblank character is not a '!'.  If
606      it is, the rest of the line is a comment.  */
607
608   do
609     {
610       loc = gfc_current_locus;
611       c = gfc_next_char_literal (0);
612     }
613   while (gfc_is_whitespace (c));
614
615   if (c == '!')
616     goto blank_line;
617   gfc_current_locus = loc;
618
619   if (c == ';')
620     {
621       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
622       return ST_NONE;
623     }
624
625   if (gfc_match_eos () == MATCH_YES)
626     goto blank_line;
627
628   /* At this point, we've got a nonblank statement to parse.  */
629   return decode_statement ();
630
631 blank_line:
632   if (digit_flag)
633     gfc_warning ("Ignoring statement label in empty statement at %C");
634   gfc_advance_line ();
635   return ST_NONE;
636 }
637
638
639 /* Return the next non-ST_NONE statement to the caller.  We also worry
640    about including files and the ends of include files at this stage.  */
641
642 static gfc_statement
643 next_statement (void)
644 {
645   gfc_statement st;
646
647   gfc_new_block = NULL;
648
649   for (;;)
650     {
651       gfc_statement_label = NULL;
652       gfc_buffer_error (1);
653
654       if (gfc_at_eol ())
655         {
656           if (gfc_option.warn_line_truncation
657               && gfc_current_locus.lb
658               && gfc_current_locus.lb->truncated)
659             gfc_warning_now ("Line truncated at %C");
660
661           gfc_advance_line ();
662         }
663
664       gfc_skip_comments ();
665
666       if (gfc_at_end ())
667         {
668           st = ST_NONE;
669           break;
670         }
671
672       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
673
674       if (st != ST_NONE)
675         break;
676     }
677
678   gfc_buffer_error (0);
679
680   if (st != ST_NONE)
681     check_statement_label (st);
682
683   return st;
684 }
685
686
687 /****************************** Parser ***********************************/
688
689 /* The parser subroutines are of type 'try' that fail if the file ends
690    unexpectedly.  */
691
692 /* Macros that expand to case-labels for various classes of
693    statements.  Start with executable statements that directly do
694    things.  */
695
696 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
697   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
698   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
699   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
700   case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
701   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
702   case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
703   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
704   case ST_OMP_BARRIER
705
706 /* Statements that mark other executable statements.  */
707
708 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
709   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
710   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
711   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
712   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
713   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
714
715 /* Declaration statements */
716
717 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
718   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
719   case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
720
721 /* Block end statements.  Errors associated with interchanging these
722    are detected in gfc_match_end().  */
723
724 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
725                  case ST_END_PROGRAM: case ST_END_SUBROUTINE
726
727
728 /* Push a new state onto the stack.  */
729
730 static void
731 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
732 {
733   p->state = new_state;
734   p->previous = gfc_state_stack;
735   p->sym = sym;
736   p->head = p->tail = NULL;
737   p->do_variable = NULL;
738   gfc_state_stack = p;
739 }
740
741
742 /* Pop the current state.  */
743
744 static void
745 pop_state (void)
746 {
747   gfc_state_stack = gfc_state_stack->previous;
748 }
749
750
751 /* Try to find the given state in the state stack.  */
752
753 try
754 gfc_find_state (gfc_compile_state state)
755 {
756   gfc_state_data *p;
757
758   for (p = gfc_state_stack; p; p = p->previous)
759     if (p->state == state)
760       break;
761
762   return (p == NULL) ? FAILURE : SUCCESS;
763 }
764
765
766 /* Starts a new level in the statement list.  */
767
768 static gfc_code *
769 new_level (gfc_code *q)
770 {
771   gfc_code *p;
772
773   p = q->block = gfc_get_code ();
774
775   gfc_state_stack->head = gfc_state_stack->tail = p;
776
777   return p;
778 }
779
780
781 /* Add the current new_st code structure and adds it to the current
782    program unit.  As a side-effect, it zeroes the new_st.  */
783
784 static gfc_code *
785 add_statement (void)
786 {
787   gfc_code *p;
788
789   p = gfc_get_code ();
790   *p = new_st;
791
792   p->loc = gfc_current_locus;
793
794   if (gfc_state_stack->head == NULL)
795     gfc_state_stack->head = p;
796   else
797     gfc_state_stack->tail->next = p;
798
799   while (p->next != NULL)
800     p = p->next;
801
802   gfc_state_stack->tail = p;
803
804   gfc_clear_new_st ();
805
806   return p;
807 }
808
809
810 /* Frees everything associated with the current statement.  */
811
812 static void
813 undo_new_statement (void)
814 {
815   gfc_free_statements (new_st.block);
816   gfc_free_statements (new_st.next);
817   gfc_free_statement (&new_st);
818   gfc_clear_new_st ();
819 }
820
821
822 /* If the current statement has a statement label, make sure that it
823    is allowed to, or should have one.  */
824
825 static void
826 check_statement_label (gfc_statement st)
827 {
828   gfc_sl_type type;
829
830   if (gfc_statement_label == NULL)
831     {
832       if (st == ST_FORMAT)
833         gfc_error ("FORMAT statement at %L does not have a statement label",
834                    &new_st.loc);
835       return;
836     }
837
838   switch (st)
839     {
840     case ST_END_PROGRAM:
841     case ST_END_FUNCTION:
842     case ST_END_SUBROUTINE:
843     case ST_ENDDO:
844     case ST_ENDIF:
845     case ST_END_SELECT:
846     case_executable:
847     case_exec_markers:
848       type = ST_LABEL_TARGET;
849       break;
850
851     case ST_FORMAT:
852       type = ST_LABEL_FORMAT;
853       break;
854
855       /* Statement labels are not restricted from appearing on a
856          particular line.  However, there are plenty of situations
857          where the resulting label can't be referenced.  */
858
859     default:
860       type = ST_LABEL_BAD_TARGET;
861       break;
862     }
863
864   gfc_define_st_label (gfc_statement_label, type, &label_locus);
865
866   new_st.here = gfc_statement_label;
867 }
868
869
870 /* Figures out what the enclosing program unit is.  This will be a
871    function, subroutine, program, block data or module.  */
872
873 gfc_state_data *
874 gfc_enclosing_unit (gfc_compile_state * result)
875 {
876   gfc_state_data *p;
877
878   for (p = gfc_state_stack; p; p = p->previous)
879     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
880         || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
881         || p->state == COMP_PROGRAM)
882       {
883
884         if (result != NULL)
885           *result = p->state;
886         return p;
887       }
888
889   if (result != NULL)
890     *result = COMP_PROGRAM;
891   return NULL;
892 }
893
894
895 /* Translate a statement enum to a string.  */
896
897 const char *
898 gfc_ascii_statement (gfc_statement st)
899 {
900   const char *p;
901
902   switch (st)
903     {
904     case ST_ARITHMETIC_IF:
905       p = _("arithmetic IF");
906       break;
907     case ST_ALLOCATE:
908       p = "ALLOCATE";
909       break;
910     case ST_ATTR_DECL:
911       p = _("attribute declaration");
912       break;
913     case ST_BACKSPACE:
914       p = "BACKSPACE";
915       break;
916     case ST_BLOCK_DATA:
917       p = "BLOCK DATA";
918       break;
919     case ST_CALL:
920       p = "CALL";
921       break;
922     case ST_CASE:
923       p = "CASE";
924       break;
925     case ST_CLOSE:
926       p = "CLOSE";
927       break;
928     case ST_COMMON:
929       p = "COMMON";
930       break;
931     case ST_CONTINUE:
932       p = "CONTINUE";
933       break;
934     case ST_CONTAINS:
935       p = "CONTAINS";
936       break;
937     case ST_CYCLE:
938       p = "CYCLE";
939       break;
940     case ST_DATA_DECL:
941       p = _("data declaration");
942       break;
943     case ST_DATA:
944       p = "DATA";
945       break;
946     case ST_DEALLOCATE:
947       p = "DEALLOCATE";
948       break;
949     case ST_DERIVED_DECL:
950       p = _("derived type declaration");
951       break;
952     case ST_DO:
953       p = "DO";
954       break;
955     case ST_ELSE:
956       p = "ELSE";
957       break;
958     case ST_ELSEIF:
959       p = "ELSE IF";
960       break;
961     case ST_ELSEWHERE:
962       p = "ELSEWHERE";
963       break;
964     case ST_END_BLOCK_DATA:
965       p = "END BLOCK DATA";
966       break;
967     case ST_ENDDO:
968       p = "END DO";
969       break;
970     case ST_END_FILE:
971       p = "END FILE";
972       break;
973     case ST_END_FORALL:
974       p = "END FORALL";
975       break;
976     case ST_END_FUNCTION:
977       p = "END FUNCTION";
978       break;
979     case ST_ENDIF:
980       p = "END IF";
981       break;
982     case ST_END_INTERFACE:
983       p = "END INTERFACE";
984       break;
985     case ST_END_MODULE:
986       p = "END MODULE";
987       break;
988     case ST_END_PROGRAM:
989       p = "END PROGRAM";
990       break;
991     case ST_END_SELECT:
992       p = "END SELECT";
993       break;
994     case ST_END_SUBROUTINE:
995       p = "END SUBROUTINE";
996       break;
997     case ST_END_WHERE:
998       p = "END WHERE";
999       break;
1000     case ST_END_TYPE:
1001       p = "END TYPE";
1002       break;
1003     case ST_ENTRY:
1004       p = "ENTRY";
1005       break;
1006     case ST_EQUIVALENCE:
1007       p = "EQUIVALENCE";
1008       break;
1009     case ST_EXIT:
1010       p = "EXIT";
1011       break;
1012     case ST_FLUSH:
1013       p = "FLUSH";
1014       break;
1015     case ST_FORALL_BLOCK:       /* Fall through */
1016     case ST_FORALL:
1017       p = "FORALL";
1018       break;
1019     case ST_FORMAT:
1020       p = "FORMAT";
1021       break;
1022     case ST_FUNCTION:
1023       p = "FUNCTION";
1024       break;
1025     case ST_GOTO:
1026       p = "GOTO";
1027       break;
1028     case ST_IF_BLOCK:
1029       p = _("block IF");
1030       break;
1031     case ST_IMPLICIT:
1032       p = "IMPLICIT";
1033       break;
1034     case ST_IMPLICIT_NONE:
1035       p = "IMPLICIT NONE";
1036       break;
1037     case ST_IMPLIED_ENDDO:
1038       p = _("implied END DO");
1039       break;
1040     case ST_IMPORT:
1041       p = "IMPORT";
1042       break;
1043     case ST_INQUIRE:
1044       p = "INQUIRE";
1045       break;
1046     case ST_INTERFACE:
1047       p = "INTERFACE";
1048       break;
1049     case ST_PARAMETER:
1050       p = "PARAMETER";
1051       break;
1052     case ST_PRIVATE:
1053       p = "PRIVATE";
1054       break;
1055     case ST_PUBLIC:
1056       p = "PUBLIC";
1057       break;
1058     case ST_MODULE:
1059       p = "MODULE";
1060       break;
1061     case ST_PAUSE:
1062       p = "PAUSE";
1063       break;
1064     case ST_MODULE_PROC:
1065       p = "MODULE PROCEDURE";
1066       break;
1067     case ST_NAMELIST:
1068       p = "NAMELIST";
1069       break;
1070     case ST_NULLIFY:
1071       p = "NULLIFY";
1072       break;
1073     case ST_OPEN:
1074       p = "OPEN";
1075       break;
1076     case ST_PROGRAM:
1077       p = "PROGRAM";
1078       break;
1079     case ST_READ:
1080       p = "READ";
1081       break;
1082     case ST_RETURN:
1083       p = "RETURN";
1084       break;
1085     case ST_REWIND:
1086       p = "REWIND";
1087       break;
1088     case ST_STOP:
1089       p = "STOP";
1090       break;
1091     case ST_SUBROUTINE:
1092       p = "SUBROUTINE";
1093       break;
1094     case ST_TYPE:
1095       p = "TYPE";
1096       break;
1097     case ST_USE:
1098       p = "USE";
1099       break;
1100     case ST_WHERE_BLOCK:        /* Fall through */
1101     case ST_WHERE:
1102       p = "WHERE";
1103       break;
1104     case ST_WRITE:
1105       p = "WRITE";
1106       break;
1107     case ST_ASSIGNMENT:
1108       p = _("assignment");
1109       break;
1110     case ST_POINTER_ASSIGNMENT:
1111       p = _("pointer assignment");
1112       break;
1113     case ST_SELECT_CASE:
1114       p = "SELECT CASE";
1115       break;
1116     case ST_SEQUENCE:
1117       p = "SEQUENCE";
1118       break;
1119     case ST_SIMPLE_IF:
1120       p = _("simple IF");
1121       break;
1122     case ST_STATEMENT_FUNCTION:
1123       p = "STATEMENT FUNCTION";
1124       break;
1125     case ST_LABEL_ASSIGNMENT:
1126       p = "LABEL ASSIGNMENT";
1127       break;
1128     case ST_ENUM:
1129       p = "ENUM DEFINITION";
1130       break;
1131     case ST_ENUMERATOR:
1132       p = "ENUMERATOR DEFINITION";
1133       break;
1134     case ST_END_ENUM:
1135       p = "END ENUM";
1136       break;
1137     case ST_OMP_ATOMIC:
1138       p = "!$OMP ATOMIC";
1139       break;
1140     case ST_OMP_BARRIER:
1141       p = "!$OMP BARRIER";
1142       break;
1143     case ST_OMP_CRITICAL:
1144       p = "!$OMP CRITICAL";
1145       break;
1146     case ST_OMP_DO:
1147       p = "!$OMP DO";
1148       break;
1149     case ST_OMP_END_CRITICAL:
1150       p = "!$OMP END CRITICAL";
1151       break;
1152     case ST_OMP_END_DO:
1153       p = "!$OMP END DO";
1154       break;
1155     case ST_OMP_END_MASTER:
1156       p = "!$OMP END MASTER";
1157       break;
1158     case ST_OMP_END_ORDERED:
1159       p = "!$OMP END ORDERED";
1160       break;
1161     case ST_OMP_END_PARALLEL:
1162       p = "!$OMP END PARALLEL";
1163       break;
1164     case ST_OMP_END_PARALLEL_DO:
1165       p = "!$OMP END PARALLEL DO";
1166       break;
1167     case ST_OMP_END_PARALLEL_SECTIONS:
1168       p = "!$OMP END PARALLEL SECTIONS";
1169       break;
1170     case ST_OMP_END_PARALLEL_WORKSHARE:
1171       p = "!$OMP END PARALLEL WORKSHARE";
1172       break;
1173     case ST_OMP_END_SECTIONS:
1174       p = "!$OMP END SECTIONS";
1175       break;
1176     case ST_OMP_END_SINGLE:
1177       p = "!$OMP END SINGLE";
1178       break;
1179     case ST_OMP_END_WORKSHARE:
1180       p = "!$OMP END WORKSHARE";
1181       break;
1182     case ST_OMP_FLUSH:
1183       p = "!$OMP FLUSH";
1184       break;
1185     case ST_OMP_MASTER:
1186       p = "!$OMP MASTER";
1187       break;
1188     case ST_OMP_ORDERED:
1189       p = "!$OMP ORDERED";
1190       break;
1191     case ST_OMP_PARALLEL:
1192       p = "!$OMP PARALLEL";
1193       break;
1194     case ST_OMP_PARALLEL_DO:
1195       p = "!$OMP PARALLEL DO";
1196       break;
1197     case ST_OMP_PARALLEL_SECTIONS:
1198       p = "!$OMP PARALLEL SECTIONS";
1199       break;
1200     case ST_OMP_PARALLEL_WORKSHARE:
1201       p = "!$OMP PARALLEL WORKSHARE";
1202       break;
1203     case ST_OMP_SECTIONS:
1204       p = "!$OMP SECTIONS";
1205       break;
1206     case ST_OMP_SECTION:
1207       p = "!$OMP SECTION";
1208       break;
1209     case ST_OMP_SINGLE:
1210       p = "!$OMP SINGLE";
1211       break;
1212     case ST_OMP_THREADPRIVATE:
1213       p = "!$OMP THREADPRIVATE";
1214       break;
1215     case ST_OMP_WORKSHARE:
1216       p = "!$OMP WORKSHARE";
1217       break;
1218     default:
1219       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1220     }
1221
1222   return p;
1223 }
1224
1225
1226 /* Create a symbol for the main program and assign it to ns->proc_name.  */
1227  
1228 static void 
1229 main_program_symbol (gfc_namespace *ns)
1230 {
1231   gfc_symbol *main_program;
1232   symbol_attribute attr;
1233
1234   gfc_get_symbol ("MAIN__", ns, &main_program);
1235   gfc_clear_attr (&attr);
1236   attr.flavor = FL_PROCEDURE;
1237   attr.proc = PROC_UNKNOWN;
1238   attr.subroutine = 1;
1239   attr.access = ACCESS_PUBLIC;
1240   attr.is_main_program = 1;
1241   main_program->attr = attr;
1242   main_program->declared_at = gfc_current_locus;
1243   ns->proc_name = main_program;
1244   gfc_commit_symbols ();
1245 }
1246
1247
1248 /* Do whatever is necessary to accept the last statement.  */
1249
1250 static void
1251 accept_statement (gfc_statement st)
1252 {
1253   switch (st)
1254     {
1255     case ST_USE:
1256       gfc_use_module ();
1257       break;
1258
1259     case ST_IMPLICIT_NONE:
1260       gfc_set_implicit_none ();
1261       break;
1262
1263     case ST_IMPLICIT:
1264       break;
1265
1266     case ST_FUNCTION:
1267     case ST_SUBROUTINE:
1268     case ST_MODULE:
1269       gfc_current_ns->proc_name = gfc_new_block;
1270       break;
1271
1272       /* If the statement is the end of a block, lay down a special code
1273          that allows a branch to the end of the block from within the
1274          construct.  */
1275
1276     case ST_ENDIF:
1277     case ST_END_SELECT:
1278       if (gfc_statement_label != NULL)
1279         {
1280           new_st.op = EXEC_NOP;
1281           add_statement ();
1282         }
1283
1284       break;
1285
1286       /* The end-of-program unit statements do not get the special
1287          marker and require a statement of some sort if they are a
1288          branch target.  */
1289
1290     case ST_END_PROGRAM:
1291     case ST_END_FUNCTION:
1292     case ST_END_SUBROUTINE:
1293       if (gfc_statement_label != NULL)
1294         {
1295           new_st.op = EXEC_RETURN;
1296           add_statement ();
1297         }
1298
1299       break;
1300
1301     case ST_ENTRY:
1302     case_executable:
1303     case_exec_markers:
1304       add_statement ();
1305       break;
1306
1307     default:
1308       break;
1309     }
1310
1311   gfc_commit_symbols ();
1312   gfc_warning_check ();
1313   gfc_clear_new_st ();
1314 }
1315
1316
1317 /* Undo anything tentative that has been built for the current
1318    statement.  */
1319
1320 static void
1321 reject_statement (void)
1322 {
1323   gfc_new_block = NULL;
1324   gfc_undo_symbols ();
1325   gfc_clear_warning ();
1326   undo_new_statement ();
1327 }
1328
1329
1330 /* Generic complaint about an out of order statement.  We also do
1331    whatever is necessary to clean up.  */
1332
1333 static void
1334 unexpected_statement (gfc_statement st)
1335 {
1336   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1337
1338   reject_statement ();
1339 }
1340
1341
1342 /* Given the next statement seen by the matcher, make sure that it is
1343    in proper order with the last.  This subroutine is initialized by
1344    calling it with an argument of ST_NONE.  If there is a problem, we
1345    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1346
1347    Individual parsers need to verify that the statements seen are
1348    valid before calling here, ie ENTRY statements are not allowed in
1349    INTERFACE blocks.  The following diagram is taken from the standard:
1350
1351             +---------------------------------------+
1352             | program  subroutine  function  module |
1353             +---------------------------------------+
1354             |            use               |
1355             +---------------------------------------+
1356             |            import         |
1357             +---------------------------------------+
1358             |   |       implicit none    |
1359             |   +-----------+------------------+
1360             |   | parameter |  implicit |
1361             |   +-----------+------------------+
1362             | format |     |  derived type    |
1363             | entry  | parameter |  interface       |
1364             |   |   data    |  specification   |
1365             |   |          |  statement func  |
1366             |   +-----------+------------------+
1367             |   |   data    |    executable    |
1368             +--------+-----------+------------------+
1369             |           contains               |
1370             +---------------------------------------+
1371             |      internal module/subprogram       |
1372             +---------------------------------------+
1373             |              end           |
1374             +---------------------------------------+
1375
1376 */
1377
1378 typedef struct
1379 {
1380   enum
1381   { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
1382     ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
1383   }
1384   state;
1385   gfc_statement last_statement;
1386   locus where;
1387 }
1388 st_state;
1389
1390 static try
1391 verify_st_order (st_state *p, gfc_statement st)
1392 {
1393
1394   switch (st)
1395     {
1396     case ST_NONE:
1397       p->state = ORDER_START;
1398       break;
1399
1400     case ST_USE:
1401       if (p->state > ORDER_USE)
1402         goto order;
1403       p->state = ORDER_USE;
1404       break;
1405
1406     case ST_IMPORT:
1407       if (p->state > ORDER_IMPORT)
1408         goto order;
1409       p->state = ORDER_IMPORT;
1410       break;
1411
1412     case ST_IMPLICIT_NONE:
1413       if (p->state > ORDER_IMPLICIT_NONE)
1414         goto order;
1415
1416       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1417          statement disqualifies a USE but not an IMPLICIT NONE.
1418          Duplicate IMPLICIT NONEs are caught when the implicit types
1419          are set.  */
1420
1421       p->state = ORDER_IMPLICIT_NONE;
1422       break;
1423
1424     case ST_IMPLICIT:
1425       if (p->state > ORDER_IMPLICIT)
1426         goto order;
1427       p->state = ORDER_IMPLICIT;
1428       break;
1429
1430     case ST_FORMAT:
1431     case ST_ENTRY:
1432       if (p->state < ORDER_IMPLICIT_NONE)
1433         p->state = ORDER_IMPLICIT_NONE;
1434       break;
1435
1436     case ST_PARAMETER:
1437       if (p->state >= ORDER_EXEC)
1438         goto order;
1439       if (p->state < ORDER_IMPLICIT)
1440         p->state = ORDER_IMPLICIT;
1441       break;
1442
1443     case ST_DATA:
1444       if (p->state < ORDER_SPEC)
1445         p->state = ORDER_SPEC;
1446       break;
1447
1448     case ST_PUBLIC:
1449     case ST_PRIVATE:
1450     case ST_DERIVED_DECL:
1451     case_decl:
1452       if (p->state >= ORDER_EXEC)
1453         goto order;
1454       if (p->state < ORDER_SPEC)
1455         p->state = ORDER_SPEC;
1456       break;
1457
1458     case_executable:
1459     case_exec_markers:
1460       if (p->state < ORDER_EXEC)
1461         p->state = ORDER_EXEC;
1462       break;
1463
1464     default:
1465       gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1466                           gfc_ascii_statement (st));
1467     }
1468
1469   /* All is well, record the statement in case we need it next time.  */
1470   p->where = gfc_current_locus;
1471   p->last_statement = st;
1472   return SUCCESS;
1473
1474 order:
1475   gfc_error ("%s statement at %C cannot follow %s statement at %L",
1476              gfc_ascii_statement (st),
1477              gfc_ascii_statement (p->last_statement), &p->where);
1478
1479   return FAILURE;
1480 }
1481
1482
1483 /* Handle an unexpected end of file.  This is a show-stopper...  */
1484
1485 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1486
1487 static void
1488 unexpected_eof (void)
1489 {
1490   gfc_state_data *p;
1491
1492   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1493
1494   /* Memory cleanup.  Move to "second to last".  */
1495   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1496        p = p->previous);
1497
1498   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1499   gfc_done_2 ();
1500
1501   longjmp (eof_buf, 1);
1502 }
1503
1504
1505 /* Parse a derived type.  */
1506
1507 static void
1508 parse_derived (void)
1509 {
1510   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1511   gfc_statement st;
1512   gfc_state_data s;
1513   gfc_symbol *sym;
1514   gfc_component *c;
1515
1516   error_flag = 0;
1517
1518   accept_statement (ST_DERIVED_DECL);
1519   push_state (&s, COMP_DERIVED, gfc_new_block);
1520
1521   gfc_new_block->component_access = ACCESS_PUBLIC;
1522   seen_private = 0;
1523   seen_sequence = 0;
1524   seen_component = 0;
1525
1526   compiling_type = 1;
1527
1528   while (compiling_type)
1529     {
1530       st = next_statement ();
1531       switch (st)
1532         {
1533         case ST_NONE:
1534           unexpected_eof ();
1535
1536         case ST_DATA_DECL:
1537           accept_statement (st);
1538           seen_component = 1;
1539           break;
1540
1541         case ST_END_TYPE:
1542           compiling_type = 0;
1543
1544           if (!seen_component)
1545             {
1546               gfc_error ("Derived type definition at %C has no components");
1547               error_flag = 1;
1548             }
1549
1550           accept_statement (ST_END_TYPE);
1551           break;
1552
1553         case ST_PRIVATE:
1554           if (gfc_find_state (COMP_MODULE) == FAILURE)
1555             {
1556               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1557                          "a MODULE");
1558               error_flag = 1;
1559               break;
1560             }
1561
1562           if (seen_component)
1563             {
1564               gfc_error ("PRIVATE statement at %C must precede "
1565                          "structure components");
1566               error_flag = 1;
1567               break;
1568             }
1569
1570           if (seen_private)
1571             {
1572               gfc_error ("Duplicate PRIVATE statement at %C");
1573               error_flag = 1;
1574             }
1575
1576           s.sym->component_access = ACCESS_PRIVATE;
1577           accept_statement (ST_PRIVATE);
1578           seen_private = 1;
1579           break;
1580
1581         case ST_SEQUENCE:
1582           if (seen_component)
1583             {
1584               gfc_error ("SEQUENCE statement at %C must precede "
1585                          "structure components");
1586               error_flag = 1;
1587               break;
1588             }
1589
1590           if (gfc_current_block ()->attr.sequence)
1591             gfc_warning ("SEQUENCE attribute at %C already specified in "
1592                          "TYPE statement");
1593
1594           if (seen_sequence)
1595             {
1596               gfc_error ("Duplicate SEQUENCE statement at %C");
1597               error_flag = 1;
1598             }
1599
1600           seen_sequence = 1;
1601           gfc_add_sequence (&gfc_current_block ()->attr, 
1602                             gfc_current_block ()->name, NULL);
1603           break;
1604
1605         default:
1606           unexpected_statement (st);
1607           break;
1608         }
1609     }
1610
1611   /* Look for allocatable components.  */
1612   sym = gfc_current_block ();
1613   for (c = sym->components; c; c = c->next)
1614     {
1615       if (c->allocatable
1616           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
1617         {
1618           sym->attr.alloc_comp = 1;
1619           break;
1620         }
1621      }
1622
1623   pop_state ();
1624 }
1625
1626
1627 /* Parse an ENUM.  */
1628  
1629 static void
1630 parse_enum (void)
1631 {
1632   int error_flag;
1633   gfc_statement st;
1634   int compiling_enum;
1635   gfc_state_data s;
1636   int seen_enumerator = 0;
1637
1638   error_flag = 0;
1639
1640   push_state (&s, COMP_ENUM, gfc_new_block);
1641
1642   compiling_enum = 1;
1643
1644   while (compiling_enum)
1645     {
1646       st = next_statement ();
1647       switch (st)
1648         {
1649         case ST_NONE:
1650           unexpected_eof ();
1651           break;
1652
1653         case ST_ENUMERATOR:
1654           seen_enumerator = 1;
1655           accept_statement (st);
1656           break;
1657
1658         case ST_END_ENUM:
1659           compiling_enum = 0;
1660           if (!seen_enumerator)
1661             {
1662               gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1663               error_flag = 1;
1664             }
1665           accept_statement (st);
1666           break;
1667
1668         default:
1669           gfc_free_enum_history ();
1670           unexpected_statement (st);
1671           break;
1672         }
1673     }
1674   pop_state ();
1675 }
1676
1677
1678 /* Parse an interface.  We must be able to deal with the possibility
1679    of recursive interfaces.  The parse_spec() subroutine is mutually
1680    recursive with parse_interface().  */
1681
1682 static gfc_statement parse_spec (gfc_statement);
1683
1684 static void
1685 parse_interface (void)
1686 {
1687   gfc_compile_state new_state, current_state;
1688   gfc_symbol *prog_unit, *sym;
1689   gfc_interface_info save;
1690   gfc_state_data s1, s2;
1691   gfc_statement st;
1692   locus proc_locus;
1693
1694   accept_statement (ST_INTERFACE);
1695
1696   current_interface.ns = gfc_current_ns;
1697   save = current_interface;
1698
1699   sym = (current_interface.type == INTERFACE_GENERIC
1700          || current_interface.type == INTERFACE_USER_OP)
1701         ? gfc_new_block : NULL;
1702
1703   push_state (&s1, COMP_INTERFACE, sym);
1704   current_state = COMP_NONE;
1705
1706 loop:
1707   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1708
1709   st = next_statement ();
1710   switch (st)
1711     {
1712     case ST_NONE:
1713       unexpected_eof ();
1714
1715     case ST_SUBROUTINE:
1716       new_state = COMP_SUBROUTINE;
1717       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1718                                   gfc_new_block->formal, NULL);
1719       break;
1720
1721     case ST_FUNCTION:
1722       new_state = COMP_FUNCTION;
1723       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1724                                   gfc_new_block->formal, NULL);
1725       break;
1726
1727     case ST_MODULE_PROC:        /* The module procedure matcher makes
1728                                    sure the context is correct.  */
1729       accept_statement (st);
1730       gfc_free_namespace (gfc_current_ns);
1731       goto loop;
1732
1733     case ST_END_INTERFACE:
1734       gfc_free_namespace (gfc_current_ns);
1735       gfc_current_ns = current_interface.ns;
1736       goto done;
1737
1738     default:
1739       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1740                  gfc_ascii_statement (st));
1741       reject_statement ();
1742       gfc_free_namespace (gfc_current_ns);
1743       goto loop;
1744     }
1745
1746
1747   /* Make sure that a generic interface has only subroutines or
1748      functions and that the generic name has the right attribute.  */
1749   if (current_interface.type == INTERFACE_GENERIC)
1750     {
1751       if (current_state == COMP_NONE)
1752         {
1753           if (new_state == COMP_FUNCTION)
1754             gfc_add_function (&sym->attr, sym->name, NULL);
1755           else if (new_state == COMP_SUBROUTINE)
1756             gfc_add_subroutine (&sym->attr, sym->name, NULL);
1757
1758           current_state = new_state;
1759         }
1760       else
1761         {
1762           if (new_state != current_state)
1763             {
1764               if (new_state == COMP_SUBROUTINE)
1765                 gfc_error ("SUBROUTINE at %C does not belong in a "
1766                            "generic function interface");
1767
1768               if (new_state == COMP_FUNCTION)
1769                 gfc_error ("FUNCTION at %C does not belong in a "
1770                            "generic subroutine interface");
1771             }
1772         }
1773     }
1774
1775   push_state (&s2, new_state, gfc_new_block);
1776   accept_statement (st);
1777   prog_unit = gfc_new_block;
1778   prog_unit->formal_ns = gfc_current_ns;
1779   proc_locus = gfc_current_locus;
1780
1781 decl:
1782   /* Read data declaration statements.  */
1783   st = parse_spec (ST_NONE);
1784
1785   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1786     {
1787       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1788                  gfc_ascii_statement (st));
1789       reject_statement ();
1790       goto decl;
1791     }
1792
1793   current_interface = save;
1794   gfc_add_interface (prog_unit);
1795   pop_state ();
1796
1797   if (current_interface.ns
1798         && current_interface.ns->proc_name
1799         && strcmp (current_interface.ns->proc_name->name,
1800                    prog_unit->name) == 0)
1801     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1802                "enclosing procedure", prog_unit->name, &proc_locus);
1803
1804   goto loop;
1805
1806 done:
1807   pop_state ();
1808 }
1809
1810
1811 /* Parse a set of specification statements.  Returns the statement
1812    that doesn't fit.  */
1813
1814 static gfc_statement
1815 parse_spec (gfc_statement st)
1816 {
1817   st_state ss;
1818
1819   verify_st_order (&ss, ST_NONE);
1820   if (st == ST_NONE)
1821     st = next_statement ();
1822
1823 loop:
1824   switch (st)
1825     {
1826     case ST_NONE:
1827       unexpected_eof ();
1828
1829     case ST_FORMAT:
1830     case ST_ENTRY:
1831     case ST_DATA:       /* Not allowed in interfaces */
1832       if (gfc_current_state () == COMP_INTERFACE)
1833         break;
1834
1835       /* Fall through */
1836
1837     case ST_USE:
1838     case ST_IMPORT:
1839     case ST_IMPLICIT_NONE:
1840     case ST_IMPLICIT:
1841     case ST_PARAMETER:
1842     case ST_PUBLIC:
1843     case ST_PRIVATE:
1844     case ST_DERIVED_DECL:
1845     case_decl:
1846       if (verify_st_order (&ss, st) == FAILURE)
1847         {
1848           reject_statement ();
1849           st = next_statement ();
1850           goto loop;
1851         }
1852
1853       switch (st)
1854         {
1855         case ST_INTERFACE:
1856           parse_interface ();
1857           break;
1858
1859         case ST_DERIVED_DECL:
1860           parse_derived ();
1861           break;
1862
1863         case ST_PUBLIC:
1864         case ST_PRIVATE:
1865           if (gfc_current_state () != COMP_MODULE)
1866             {
1867               gfc_error ("%s statement must appear in a MODULE",
1868                          gfc_ascii_statement (st));
1869               break;
1870             }
1871
1872           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1873             {
1874               gfc_error ("%s statement at %C follows another accessibility "
1875                          "specification", gfc_ascii_statement (st));
1876               break;
1877             }
1878
1879           gfc_current_ns->default_access = (st == ST_PUBLIC)
1880             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1881
1882           break;
1883
1884         default:
1885           break;
1886         }
1887
1888       accept_statement (st);
1889       st = next_statement ();
1890       goto loop;
1891
1892     case ST_ENUM:
1893       accept_statement (st);
1894       parse_enum();
1895       st = next_statement ();
1896       goto loop;
1897
1898     default:
1899       break;
1900     }
1901
1902   return st;
1903 }
1904
1905
1906 /* Parse a WHERE block, (not a simple WHERE statement).  */
1907
1908 static void
1909 parse_where_block (void)
1910 {
1911   int seen_empty_else;
1912   gfc_code *top, *d;
1913   gfc_state_data s;
1914   gfc_statement st;
1915
1916   accept_statement (ST_WHERE_BLOCK);
1917   top = gfc_state_stack->tail;
1918
1919   push_state (&s, COMP_WHERE, gfc_new_block);
1920
1921   d = add_statement ();
1922   d->expr = top->expr;
1923   d->op = EXEC_WHERE;
1924
1925   top->expr = NULL;
1926   top->block = d;
1927
1928   seen_empty_else = 0;
1929
1930   do
1931     {
1932       st = next_statement ();
1933       switch (st)
1934         {
1935         case ST_NONE:
1936           unexpected_eof ();
1937
1938         case ST_WHERE_BLOCK:
1939           parse_where_block ();
1940           break;
1941
1942         case ST_ASSIGNMENT:
1943         case ST_WHERE:
1944           accept_statement (st);
1945           break;
1946
1947         case ST_ELSEWHERE:
1948           if (seen_empty_else)
1949             {
1950               gfc_error ("ELSEWHERE statement at %C follows previous "
1951                          "unmasked ELSEWHERE");
1952               break;
1953             }
1954
1955           if (new_st.expr == NULL)
1956             seen_empty_else = 1;
1957
1958           d = new_level (gfc_state_stack->head);
1959           d->op = EXEC_WHERE;
1960           d->expr = new_st.expr;
1961
1962           accept_statement (st);
1963
1964           break;
1965
1966         case ST_END_WHERE:
1967           accept_statement (st);
1968           break;
1969
1970         default:
1971           gfc_error ("Unexpected %s statement in WHERE block at %C",
1972                      gfc_ascii_statement (st));
1973           reject_statement ();
1974           break;
1975         }
1976     }
1977   while (st != ST_END_WHERE);
1978
1979   pop_state ();
1980 }
1981
1982
1983 /* Parse a FORALL block (not a simple FORALL statement).  */
1984
1985 static void
1986 parse_forall_block (void)
1987 {
1988   gfc_code *top, *d;
1989   gfc_state_data s;
1990   gfc_statement st;
1991
1992   accept_statement (ST_FORALL_BLOCK);
1993   top = gfc_state_stack->tail;
1994
1995   push_state (&s, COMP_FORALL, gfc_new_block);
1996
1997   d = add_statement ();
1998   d->op = EXEC_FORALL;
1999   top->block = d;
2000
2001   do
2002     {
2003       st = next_statement ();
2004       switch (st)
2005         {
2006
2007         case ST_ASSIGNMENT:
2008         case ST_POINTER_ASSIGNMENT:
2009         case ST_WHERE:
2010         case ST_FORALL:
2011           accept_statement (st);
2012           break;
2013
2014         case ST_WHERE_BLOCK:
2015           parse_where_block ();
2016           break;
2017
2018         case ST_FORALL_BLOCK:
2019           parse_forall_block ();
2020           break;
2021
2022         case ST_END_FORALL:
2023           accept_statement (st);
2024           break;
2025
2026         case ST_NONE:
2027           unexpected_eof ();
2028
2029         default:
2030           gfc_error ("Unexpected %s statement in FORALL block at %C",
2031                      gfc_ascii_statement (st));
2032
2033           reject_statement ();
2034           break;
2035         }
2036     }
2037   while (st != ST_END_FORALL);
2038
2039   pop_state ();
2040 }
2041
2042
2043 static gfc_statement parse_executable (gfc_statement);
2044
2045 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2046
2047 static void
2048 parse_if_block (void)
2049 {
2050   gfc_code *top, *d;
2051   gfc_statement st;
2052   locus else_locus;
2053   gfc_state_data s;
2054   int seen_else;
2055
2056   seen_else = 0;
2057   accept_statement (ST_IF_BLOCK);
2058
2059   top = gfc_state_stack->tail;
2060   push_state (&s, COMP_IF, gfc_new_block);
2061
2062   new_st.op = EXEC_IF;
2063   d = add_statement ();
2064
2065   d->expr = top->expr;
2066   top->expr = NULL;
2067   top->block = d;
2068
2069   do
2070     {
2071       st = parse_executable (ST_NONE);
2072
2073       switch (st)
2074         {
2075         case ST_NONE:
2076           unexpected_eof ();
2077
2078         case ST_ELSEIF:
2079           if (seen_else)
2080             {
2081               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2082                          "statement at %L", &else_locus);
2083
2084               reject_statement ();
2085               break;
2086             }
2087
2088           d = new_level (gfc_state_stack->head);
2089           d->op = EXEC_IF;
2090           d->expr = new_st.expr;
2091
2092           accept_statement (st);
2093
2094           break;
2095
2096         case ST_ELSE:
2097           if (seen_else)
2098             {
2099               gfc_error ("Duplicate ELSE statements at %L and %C",
2100                          &else_locus);
2101               reject_statement ();
2102               break;
2103             }
2104
2105           seen_else = 1;
2106           else_locus = gfc_current_locus;
2107
2108           d = new_level (gfc_state_stack->head);
2109           d->op = EXEC_IF;
2110
2111           accept_statement (st);
2112
2113           break;
2114
2115         case ST_ENDIF:
2116           break;
2117
2118         default:
2119           unexpected_statement (st);
2120           break;
2121         }
2122     }
2123   while (st != ST_ENDIF);
2124
2125   pop_state ();
2126   accept_statement (st);
2127 }
2128
2129
2130 /* Parse a SELECT block.  */
2131
2132 static void
2133 parse_select_block (void)
2134 {
2135   gfc_statement st;
2136   gfc_code *cp;
2137   gfc_state_data s;
2138
2139   accept_statement (ST_SELECT_CASE);
2140
2141   cp = gfc_state_stack->tail;
2142   push_state (&s, COMP_SELECT, gfc_new_block);
2143
2144   /* Make sure that the next statement is a CASE or END SELECT.  */
2145   for (;;)
2146     {
2147       st = next_statement ();
2148       if (st == ST_NONE)
2149         unexpected_eof ();
2150       if (st == ST_END_SELECT)
2151         {
2152           /* Empty SELECT CASE is OK.  */
2153           accept_statement (st);
2154           pop_state ();
2155           return;
2156         }
2157       if (st == ST_CASE)
2158         break;
2159
2160       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2161                  "CASE at %C");
2162
2163       reject_statement ();
2164     }
2165
2166   /* At this point, we're got a nonempty select block.  */
2167   cp = new_level (cp);
2168   *cp = new_st;
2169
2170   accept_statement (st);
2171
2172   do
2173     {
2174       st = parse_executable (ST_NONE);
2175       switch (st)
2176         {
2177         case ST_NONE:
2178           unexpected_eof ();
2179
2180         case ST_CASE:
2181           cp = new_level (gfc_state_stack->head);
2182           *cp = new_st;
2183           gfc_clear_new_st ();
2184
2185           accept_statement (st);
2186           /* Fall through */
2187
2188         case ST_END_SELECT:
2189           break;
2190
2191         /* Can't have an executable statement because of
2192            parse_executable().  */
2193         default:
2194           unexpected_statement (st);
2195           break;
2196         }
2197     }
2198   while (st != ST_END_SELECT);
2199
2200   pop_state ();
2201   accept_statement (st);
2202 }
2203
2204
2205 /* Given a symbol, make sure it is not an iteration variable for a DO
2206    statement.  This subroutine is called when the symbol is seen in a
2207    context that causes it to become redefined.  If the symbol is an
2208    iterator, we generate an error message and return nonzero.  */
2209
2210 int 
2211 gfc_check_do_variable (gfc_symtree *st)
2212 {
2213   gfc_state_data *s;
2214
2215   for (s=gfc_state_stack; s; s = s->previous)
2216     if (s->do_variable == st)
2217       {
2218         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2219                       "loop beginning at %L", st->name, &s->head->loc);
2220         return 1;
2221       }
2222
2223   return 0;
2224 }
2225   
2226
2227 /* Checks to see if the current statement label closes an enddo.
2228    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2229    an error) if it incorrectly closes an ENDDO.  */
2230
2231 static int
2232 check_do_closure (void)
2233 {
2234   gfc_state_data *p;
2235
2236   if (gfc_statement_label == NULL)
2237     return 0;
2238
2239   for (p = gfc_state_stack; p; p = p->previous)
2240     if (p->state == COMP_DO)
2241       break;
2242
2243   if (p == NULL)
2244     return 0;           /* No loops to close */
2245
2246   if (p->ext.end_do_label == gfc_statement_label)
2247     {
2248
2249       if (p == gfc_state_stack)
2250         return 1;
2251
2252       gfc_error ("End of nonblock DO statement at %C is within another block");
2253       return 2;
2254     }
2255
2256   /* At this point, the label doesn't terminate the innermost loop.
2257      Make sure it doesn't terminate another one.  */
2258   for (; p; p = p->previous)
2259     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2260       {
2261         gfc_error ("End of nonblock DO statement at %C is interwoven "
2262                    "with another DO loop");
2263         return 2;
2264       }
2265
2266   return 0;
2267 }
2268
2269
2270 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2271    handled inside of parse_executable(), because they aren't really
2272    loop statements.  */
2273
2274 static void
2275 parse_do_block (void)
2276 {
2277   gfc_statement st;
2278   gfc_code *top;
2279   gfc_state_data s;
2280   gfc_symtree *stree;
2281
2282   s.ext.end_do_label = new_st.label;
2283
2284   if (new_st.ext.iterator != NULL)
2285     stree = new_st.ext.iterator->var->symtree;
2286   else
2287     stree = NULL;
2288
2289   accept_statement (ST_DO);
2290
2291   top = gfc_state_stack->tail;
2292   push_state (&s, COMP_DO, gfc_new_block);
2293
2294   s.do_variable = stree;
2295
2296   top->block = new_level (top);
2297   top->block->op = EXEC_DO;
2298
2299 loop:
2300   st = parse_executable (ST_NONE);
2301
2302   switch (st)
2303     {
2304     case ST_NONE:
2305       unexpected_eof ();
2306
2307     case ST_ENDDO:
2308       if (s.ext.end_do_label != NULL
2309           && s.ext.end_do_label != gfc_statement_label)
2310         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2311                        "DO label");
2312
2313       if (gfc_statement_label != NULL)
2314         {
2315           new_st.op = EXEC_NOP;
2316           add_statement ();
2317         }
2318       break;
2319
2320     case ST_IMPLIED_ENDDO:
2321      /* If the do-stmt of this DO construct has a do-construct-name,
2322         the corresponding end-do must be an end-do-stmt (with a matching
2323         name, but in that case we must have seen ST_ENDDO first).
2324         We only complain about this in pedantic mode.  */
2325      if (gfc_current_block () != NULL)
2326         gfc_error_now ("named block DO at %L requires matching ENDDO name",
2327                        &gfc_current_block()->declared_at);
2328
2329       break;
2330
2331     default:
2332       unexpected_statement (st);
2333       goto loop;
2334     }
2335
2336   pop_state ();
2337   accept_statement (st);
2338 }
2339
2340
2341 /* Parse the statements of OpenMP do/parallel do.  */
2342
2343 static gfc_statement
2344 parse_omp_do (gfc_statement omp_st)
2345 {
2346   gfc_statement st;
2347   gfc_code *cp, *np;
2348   gfc_state_data s;
2349
2350   accept_statement (omp_st);
2351
2352   cp = gfc_state_stack->tail;
2353   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2354   np = new_level (cp);
2355   np->op = cp->op;
2356   np->block = NULL;
2357
2358   for (;;)
2359     {
2360       st = next_statement ();
2361       if (st == ST_NONE)
2362         unexpected_eof ();
2363       else if (st == ST_DO)
2364         break;
2365       else
2366         unexpected_statement (st);
2367     }
2368
2369   parse_do_block ();
2370   if (gfc_statement_label != NULL
2371       && gfc_state_stack->previous != NULL
2372       && gfc_state_stack->previous->state == COMP_DO
2373       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2374     {
2375       /* In
2376          DO 100 I=1,10
2377            !$OMP DO
2378              DO J=1,10
2379              ...
2380              100 CONTINUE
2381          there should be no !$OMP END DO.  */
2382       pop_state ();
2383       return ST_IMPLIED_ENDDO;
2384     }
2385
2386   check_do_closure ();
2387   pop_state ();
2388
2389   st = next_statement ();
2390   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2391     {
2392       if (new_st.op == EXEC_OMP_END_NOWAIT)
2393         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2394       else
2395         gcc_assert (new_st.op == EXEC_NOP);
2396       gfc_clear_new_st ();
2397       gfc_commit_symbols ();
2398       gfc_warning_check ();
2399       st = next_statement ();
2400     }
2401   return st;
2402 }
2403
2404
2405 /* Parse the statements of OpenMP atomic directive.  */
2406
2407 static void
2408 parse_omp_atomic (void)
2409 {
2410   gfc_statement st;
2411   gfc_code *cp, *np;
2412   gfc_state_data s;
2413
2414   accept_statement (ST_OMP_ATOMIC);
2415
2416   cp = gfc_state_stack->tail;
2417   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2418   np = new_level (cp);
2419   np->op = cp->op;
2420   np->block = NULL;
2421
2422   for (;;)
2423     {
2424       st = next_statement ();
2425       if (st == ST_NONE)
2426         unexpected_eof ();
2427       else if (st == ST_ASSIGNMENT)
2428         break;
2429       else
2430         unexpected_statement (st);
2431     }
2432
2433   accept_statement (st);
2434
2435   pop_state ();
2436 }
2437
2438
2439 /* Parse the statements of an OpenMP structured block.  */
2440
2441 static void
2442 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2443 {
2444   gfc_statement st, omp_end_st;
2445   gfc_code *cp, *np;
2446   gfc_state_data s;
2447
2448   accept_statement (omp_st);
2449
2450   cp = gfc_state_stack->tail;
2451   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2452   np = new_level (cp);
2453   np->op = cp->op;
2454   np->block = NULL;
2455
2456   switch (omp_st)
2457     {
2458     case ST_OMP_PARALLEL:
2459       omp_end_st = ST_OMP_END_PARALLEL;
2460       break;
2461     case ST_OMP_PARALLEL_SECTIONS:
2462       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2463       break;
2464     case ST_OMP_SECTIONS:
2465       omp_end_st = ST_OMP_END_SECTIONS;
2466       break;
2467     case ST_OMP_ORDERED:
2468       omp_end_st = ST_OMP_END_ORDERED;
2469       break;
2470     case ST_OMP_CRITICAL:
2471       omp_end_st = ST_OMP_END_CRITICAL;
2472       break;
2473     case ST_OMP_MASTER:
2474       omp_end_st = ST_OMP_END_MASTER;
2475       break;
2476     case ST_OMP_SINGLE:
2477       omp_end_st = ST_OMP_END_SINGLE;
2478       break;
2479     case ST_OMP_WORKSHARE:
2480       omp_end_st = ST_OMP_END_WORKSHARE;
2481       break;
2482     case ST_OMP_PARALLEL_WORKSHARE:
2483       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2484       break;
2485     default:
2486       gcc_unreachable ();
2487     }
2488
2489   do
2490     {
2491       if (workshare_stmts_only)
2492         {
2493           /* Inside of !$omp workshare, only
2494              scalar assignments
2495              array assignments
2496              where statements and constructs
2497              forall statements and constructs
2498              !$omp atomic
2499              !$omp critical
2500              !$omp parallel
2501              are allowed.  For !$omp critical these
2502              restrictions apply recursively.  */
2503           bool cycle = true;
2504
2505           st = next_statement ();
2506           for (;;)
2507             {
2508               switch (st)
2509                 {
2510                 case ST_NONE:
2511                   unexpected_eof ();
2512
2513                 case ST_ASSIGNMENT:
2514                 case ST_WHERE:
2515                 case ST_FORALL:
2516                   accept_statement (st);
2517                   break;
2518
2519                 case ST_WHERE_BLOCK:
2520                   parse_where_block ();
2521                   break;
2522
2523                 case ST_FORALL_BLOCK:
2524                   parse_forall_block ();
2525                   break;
2526
2527                 case ST_OMP_PARALLEL:
2528                 case ST_OMP_PARALLEL_SECTIONS:
2529                   parse_omp_structured_block (st, false);
2530                   break;
2531
2532                 case ST_OMP_PARALLEL_WORKSHARE:
2533                 case ST_OMP_CRITICAL:
2534                   parse_omp_structured_block (st, true);
2535                   break;
2536
2537                 case ST_OMP_PARALLEL_DO:
2538                   st = parse_omp_do (st);
2539                   continue;
2540
2541                 case ST_OMP_ATOMIC:
2542                   parse_omp_atomic ();
2543                   break;
2544
2545                 default:
2546                   cycle = false;
2547                   break;
2548                 }
2549
2550               if (!cycle)
2551                 break;
2552
2553               st = next_statement ();
2554             }
2555         }
2556       else
2557         st = parse_executable (ST_NONE);
2558       if (st == ST_NONE)
2559         unexpected_eof ();
2560       else if (st == ST_OMP_SECTION
2561                && (omp_st == ST_OMP_SECTIONS
2562                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2563         {
2564           np = new_level (np);
2565           np->op = cp->op;
2566           np->block = NULL;
2567         }
2568       else if (st != omp_end_st)
2569         unexpected_statement (st);
2570     }
2571   while (st != omp_end_st);
2572
2573   switch (new_st.op)
2574     {
2575     case EXEC_OMP_END_NOWAIT:
2576       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2577       break;
2578     case EXEC_OMP_CRITICAL:
2579       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2580           || (new_st.ext.omp_name != NULL
2581               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2582         gfc_error ("Name after !$omp critical and !$omp end critical does "
2583                    "not match at %C");
2584       gfc_free ((char *) new_st.ext.omp_name);
2585       break;
2586     case EXEC_OMP_END_SINGLE:
2587       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2588         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2589       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2590       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2591       break;
2592     case EXEC_NOP:
2593       break;
2594     default:
2595       gcc_unreachable ();
2596     }
2597
2598   gfc_clear_new_st ();
2599   gfc_commit_symbols ();
2600   gfc_warning_check ();
2601   pop_state ();
2602 }
2603
2604
2605 /* Accept a series of executable statements.  We return the first
2606    statement that doesn't fit to the caller.  Any block statements are
2607    passed on to the correct handler, which usually passes the buck
2608    right back here.  */
2609
2610 static gfc_statement
2611 parse_executable (gfc_statement st)
2612 {
2613   int close_flag;
2614
2615   if (st == ST_NONE)
2616     st = next_statement ();
2617
2618   for (;;)
2619     {
2620       close_flag = check_do_closure ();
2621       if (close_flag)
2622         switch (st)
2623           {
2624           case ST_GOTO:
2625           case ST_END_PROGRAM:
2626           case ST_RETURN:
2627           case ST_EXIT:
2628           case ST_END_FUNCTION:
2629           case ST_CYCLE:
2630           case ST_PAUSE:
2631           case ST_STOP:
2632           case ST_END_SUBROUTINE:
2633
2634           case ST_DO:
2635           case ST_FORALL:
2636           case ST_WHERE:
2637           case ST_SELECT_CASE:
2638             gfc_error ("%s statement at %C cannot terminate a non-block "
2639                        "DO loop", gfc_ascii_statement (st));
2640             break;
2641
2642           default:
2643             break;
2644           }
2645
2646       switch (st)
2647         {
2648         case ST_NONE:
2649           unexpected_eof ();
2650
2651         case ST_FORMAT:
2652         case ST_DATA:
2653         case ST_ENTRY:
2654         case_executable:
2655           accept_statement (st);
2656           if (close_flag == 1)
2657             return ST_IMPLIED_ENDDO;
2658           break;
2659
2660         case ST_IF_BLOCK:
2661           parse_if_block ();
2662           break;
2663
2664         case ST_SELECT_CASE:
2665           parse_select_block ();
2666           break;
2667
2668         case ST_DO:
2669           parse_do_block ();
2670           if (check_do_closure () == 1)
2671             return ST_IMPLIED_ENDDO;
2672           break;
2673
2674         case ST_WHERE_BLOCK:
2675           parse_where_block ();
2676           break;
2677
2678         case ST_FORALL_BLOCK:
2679           parse_forall_block ();
2680           break;
2681
2682         case ST_OMP_PARALLEL:
2683         case ST_OMP_PARALLEL_SECTIONS:
2684         case ST_OMP_SECTIONS:
2685         case ST_OMP_ORDERED:
2686         case ST_OMP_CRITICAL:
2687         case ST_OMP_MASTER:
2688         case ST_OMP_SINGLE:
2689           parse_omp_structured_block (st, false);
2690           break;
2691
2692         case ST_OMP_WORKSHARE:
2693         case ST_OMP_PARALLEL_WORKSHARE:
2694           parse_omp_structured_block (st, true);
2695           break;
2696
2697         case ST_OMP_DO:
2698         case ST_OMP_PARALLEL_DO:
2699           st = parse_omp_do (st);
2700           if (st == ST_IMPLIED_ENDDO)
2701             return st;
2702           continue;
2703
2704         case ST_OMP_ATOMIC:
2705           parse_omp_atomic ();
2706           break;
2707
2708         default:
2709           return st;
2710         }
2711
2712       st = next_statement ();
2713     }
2714 }
2715
2716
2717 /* Parse a series of contained program units.  */
2718
2719 static void parse_progunit (gfc_statement);
2720
2721
2722 /* Fix the symbols for sibling functions.  These are incorrectly added to
2723    the child namespace as the parser didn't know about this procedure.  */
2724
2725 static void
2726 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
2727 {
2728   gfc_namespace *ns;
2729   gfc_symtree *st;
2730   gfc_symbol *old_sym;
2731
2732   sym->attr.referenced = 1;
2733   for (ns = siblings; ns; ns = ns->sibling)
2734     {
2735       gfc_find_sym_tree (sym->name, ns, 0, &st);
2736
2737       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
2738         continue;
2739
2740       old_sym = st->n.sym;
2741       if ((old_sym->attr.flavor == FL_PROCEDURE
2742            || old_sym->ts.type == BT_UNKNOWN)
2743           && old_sym->ns == ns
2744           && !old_sym->attr.contained)
2745         {
2746           /* Replace it with the symbol from the parent namespace.  */
2747           st->n.sym = sym;
2748           sym->refs++;
2749
2750           /* Free the old (local) symbol.  */
2751           old_sym->refs--;
2752           if (old_sym->refs == 0)
2753             gfc_free_symbol (old_sym);
2754         }
2755
2756       /* Do the same for any contained procedures.  */
2757       gfc_fixup_sibling_symbols (sym, ns->contained);
2758     }
2759 }
2760
2761 static void
2762 parse_contained (int module)
2763 {
2764   gfc_namespace *ns, *parent_ns;
2765   gfc_state_data s1, s2;
2766   gfc_statement st;
2767   gfc_symbol *sym;
2768   gfc_entry_list *el;
2769   int contains_statements = 0;
2770
2771   push_state (&s1, COMP_CONTAINS, NULL);
2772   parent_ns = gfc_current_ns;
2773
2774   do
2775     {
2776       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2777
2778       gfc_current_ns->sibling = parent_ns->contained;
2779       parent_ns->contained = gfc_current_ns;
2780
2781       st = next_statement ();
2782
2783       switch (st)
2784         {
2785         case ST_NONE:
2786           unexpected_eof ();
2787
2788         case ST_FUNCTION:
2789         case ST_SUBROUTINE:
2790           contains_statements = 1;
2791           accept_statement (st);
2792
2793           push_state (&s2,
2794                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2795                       gfc_new_block);
2796
2797           /* For internal procedures, create/update the symbol in the
2798              parent namespace.  */
2799
2800           if (!module)
2801             {
2802               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2803                 gfc_error ("Contained procedure '%s' at %C is already "
2804                            "ambiguous", gfc_new_block->name);
2805               else
2806                 {
2807                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2808                                          &gfc_new_block->declared_at) ==
2809                       SUCCESS)
2810                     {
2811                       if (st == ST_FUNCTION)
2812                         gfc_add_function (&sym->attr, sym->name,
2813                                           &gfc_new_block->declared_at);
2814                       else
2815                         gfc_add_subroutine (&sym->attr, sym->name,
2816                                             &gfc_new_block->declared_at);
2817                     }
2818                 }
2819
2820               gfc_commit_symbols ();
2821             }
2822           else
2823             sym = gfc_new_block;
2824
2825           /* Mark this as a contained function, so it isn't replaced
2826              by other module functions.  */
2827           sym->attr.contained = 1;
2828           sym->attr.referenced = 1;
2829
2830           parse_progunit (ST_NONE);
2831
2832           /* Fix up any sibling functions that refer to this one.  */
2833           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2834           /* Or refer to any of its alternate entry points.  */
2835           for (el = gfc_current_ns->entries; el; el = el->next)
2836             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2837
2838           gfc_current_ns->code = s2.head;
2839           gfc_current_ns = parent_ns;
2840
2841           pop_state ();
2842           break;
2843
2844         /* These statements are associated with the end of the host unit.  */
2845         case ST_END_FUNCTION:
2846         case ST_END_MODULE:
2847         case ST_END_PROGRAM:
2848         case ST_END_SUBROUTINE:
2849           accept_statement (st);
2850           break;
2851
2852         default:
2853           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2854                      gfc_ascii_statement (st));
2855           reject_statement ();
2856           break;
2857         }
2858     }
2859   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2860          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2861
2862   /* The first namespace in the list is guaranteed to not have
2863      anything (worthwhile) in it.  */
2864
2865   gfc_current_ns = parent_ns;
2866
2867   ns = gfc_current_ns->contained;
2868   gfc_current_ns->contained = ns->sibling;
2869   gfc_free_namespace (ns);
2870
2871   pop_state ();
2872   if (!contains_statements)
2873     /* This is valid in Fortran 2008.  */
2874     gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
2875                     "FUNCTION or SUBROUTINE statement at %C");
2876 }
2877
2878
2879 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2880
2881 static void
2882 parse_progunit (gfc_statement st)
2883 {
2884   gfc_state_data *p;
2885   int n;
2886
2887   st = parse_spec (st);
2888   switch (st)
2889     {
2890     case ST_NONE:
2891       unexpected_eof ();
2892
2893     case ST_CONTAINS:
2894       goto contains;
2895
2896     case_end:
2897       accept_statement (st);
2898       goto done;
2899
2900     default:
2901       break;
2902     }
2903
2904 loop:
2905   for (;;)
2906     {
2907       st = parse_executable (st);
2908
2909       switch (st)
2910         {
2911         case ST_NONE:
2912           unexpected_eof ();
2913
2914         case ST_CONTAINS:
2915           goto contains;
2916
2917         case_end:
2918           accept_statement (st);
2919           goto done;
2920
2921         default:
2922           break;
2923         }
2924
2925       unexpected_statement (st);
2926       reject_statement ();
2927       st = next_statement ();
2928     }
2929
2930 contains:
2931   n = 0;
2932
2933   for (p = gfc_state_stack; p; p = p->previous)
2934     if (p->state == COMP_CONTAINS)
2935       n++;
2936
2937   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2938     n--;
2939
2940   if (n > 0)
2941     {
2942       gfc_error ("CONTAINS statement at %C is already in a contained "
2943                  "program unit");
2944       st = next_statement ();
2945       goto loop;
2946     }
2947
2948   parse_contained (0);
2949
2950 done:
2951   gfc_current_ns->code = gfc_state_stack->head;
2952 }
2953
2954
2955 /* Come here to complain about a global symbol already in use as
2956    something else.  */
2957
2958 void
2959 global_used (gfc_gsymbol *sym, locus *where)
2960 {
2961   const char *name;
2962
2963   if (where == NULL)
2964     where = &gfc_current_locus;
2965
2966   switch(sym->type)
2967     {
2968     case GSYM_PROGRAM:
2969       name = "PROGRAM";
2970       break;
2971     case GSYM_FUNCTION:
2972       name = "FUNCTION";
2973       break;
2974     case GSYM_SUBROUTINE:
2975       name = "SUBROUTINE";
2976       break;
2977     case GSYM_COMMON:
2978       name = "COMMON";
2979       break;
2980     case GSYM_BLOCK_DATA:
2981       name = "BLOCK DATA";
2982       break;
2983     case GSYM_MODULE:
2984       name = "MODULE";
2985       break;
2986     default:
2987       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2988       name = NULL;
2989     }
2990
2991   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2992               sym->name, where, name, &sym->where);
2993 }
2994
2995
2996 /* Parse a block data program unit.  */
2997
2998 static void
2999 parse_block_data (void)
3000 {
3001   gfc_statement st;
3002   static locus blank_locus;
3003   static int blank_block=0;
3004   gfc_gsymbol *s;
3005
3006   gfc_current_ns->proc_name = gfc_new_block;
3007   gfc_current_ns->is_block_data = 1;
3008
3009   if (gfc_new_block == NULL)
3010     {
3011       if (blank_block)
3012        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3013                   "prior BLOCK DATA at %L", &blank_locus);
3014       else
3015        {
3016          blank_block = 1;
3017          blank_locus = gfc_current_locus;
3018        }
3019     }
3020   else
3021     {
3022       s = gfc_get_gsymbol (gfc_new_block->name);
3023       if (s->defined
3024           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3025        global_used(s, NULL);
3026       else
3027        {
3028          s->type = GSYM_BLOCK_DATA;
3029          s->where = gfc_current_locus;
3030          s->defined = 1;
3031        }
3032     }
3033
3034   st = parse_spec (ST_NONE);
3035
3036   while (st != ST_END_BLOCK_DATA)
3037     {
3038       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3039                  gfc_ascii_statement (st));
3040       reject_statement ();
3041       st = next_statement ();
3042     }
3043 }
3044
3045
3046 /* Parse a module subprogram.  */
3047
3048 static void
3049 parse_module (void)
3050 {
3051   gfc_statement st;
3052   gfc_gsymbol *s;
3053
3054   s = gfc_get_gsymbol (gfc_new_block->name);
3055   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3056     global_used(s, NULL);
3057   else
3058     {
3059       s->type = GSYM_MODULE;
3060       s->where = gfc_current_locus;
3061       s->defined = 1;
3062     }
3063
3064   st = parse_spec (ST_NONE);
3065
3066 loop:
3067   switch (st)
3068     {
3069     case ST_NONE:
3070       unexpected_eof ();
3071
3072     case ST_CONTAINS:
3073       parse_contained (1);
3074       break;
3075
3076     case ST_END_MODULE:
3077       accept_statement (st);
3078       break;
3079
3080     default:
3081       gfc_error ("Unexpected %s statement in MODULE at %C",
3082                  gfc_ascii_statement (st));
3083
3084       reject_statement ();
3085       st = next_statement ();
3086       goto loop;
3087     }
3088 }
3089
3090
3091 /* Add a procedure name to the global symbol table.  */
3092
3093 static void
3094 add_global_procedure (int sub)
3095 {
3096   gfc_gsymbol *s;
3097
3098   s = gfc_get_gsymbol(gfc_new_block->name);
3099
3100   if (s->defined
3101       || (s->type != GSYM_UNKNOWN
3102           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3103     global_used(s, NULL);
3104   else
3105     {
3106       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3107       s->where = gfc_current_locus;
3108       s->defined = 1;
3109     }
3110 }
3111
3112
3113 /* Add a program to the global symbol table.  */
3114
3115 static void
3116 add_global_program (void)
3117 {
3118   gfc_gsymbol *s;
3119
3120   if (gfc_new_block == NULL)
3121     return;
3122   s = gfc_get_gsymbol (gfc_new_block->name);
3123
3124   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3125     global_used(s, NULL);
3126   else
3127     {
3128       s->type = GSYM_PROGRAM;
3129       s->where = gfc_current_locus;
3130       s->defined = 1;
3131     }
3132 }
3133
3134
3135 /* Top level parser.  */
3136
3137 try
3138 gfc_parse_file (void)
3139 {
3140   int seen_program, errors_before, errors;
3141   gfc_state_data top, s;
3142   gfc_statement st;
3143   locus prog_locus;
3144
3145   top.state = COMP_NONE;
3146   top.sym = NULL;
3147   top.previous = NULL;
3148   top.head = top.tail = NULL;
3149   top.do_variable = NULL;
3150
3151   gfc_state_stack = &top;
3152
3153   gfc_clear_new_st ();
3154
3155   gfc_statement_label = NULL;
3156
3157   if (setjmp (eof_buf))
3158     return FAILURE;     /* Come here on unexpected EOF */
3159
3160   seen_program = 0;
3161
3162   /* Exit early for empty files.  */
3163   if (gfc_at_eof ())
3164     goto done;
3165
3166 loop:
3167   gfc_init_2 ();
3168   st = next_statement ();
3169   switch (st)
3170     {
3171     case ST_NONE:
3172       gfc_done_2 ();
3173       goto done;
3174
3175     case ST_PROGRAM:
3176       if (seen_program)
3177         goto duplicate_main;
3178       seen_program = 1;
3179       prog_locus = gfc_current_locus;
3180
3181       push_state (&s, COMP_PROGRAM, gfc_new_block);
3182       main_program_symbol(gfc_current_ns);
3183       accept_statement (st);
3184       add_global_program ();
3185       parse_progunit (ST_NONE);
3186       break;
3187
3188     case ST_SUBROUTINE:
3189       add_global_procedure (1);
3190       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3191       accept_statement (st);
3192       parse_progunit (ST_NONE);
3193       break;
3194
3195     case ST_FUNCTION:
3196       add_global_procedure (0);
3197       push_state (&s, COMP_FUNCTION, gfc_new_block);
3198       accept_statement (st);
3199       parse_progunit (ST_NONE);
3200       break;
3201
3202     case ST_BLOCK_DATA:
3203       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3204       accept_statement (st);
3205       parse_block_data ();
3206       break;
3207
3208     case ST_MODULE:
3209       push_state (&s, COMP_MODULE, gfc_new_block);
3210       accept_statement (st);
3211
3212       gfc_get_errors (NULL, &errors_before);
3213       parse_module ();
3214       break;
3215
3216     /* Anything else starts a nameless main program block.  */
3217     default:
3218       if (seen_program)
3219         goto duplicate_main;
3220       seen_program = 1;
3221       prog_locus = gfc_current_locus;
3222
3223       push_state (&s, COMP_PROGRAM, gfc_new_block);
3224       main_program_symbol (gfc_current_ns);
3225       parse_progunit (st);
3226       break;
3227     }
3228
3229   gfc_current_ns->code = s.head;
3230
3231   gfc_resolve (gfc_current_ns);
3232
3233   /* Dump the parse tree if requested.  */
3234   if (gfc_option.verbose)
3235     gfc_show_namespace (gfc_current_ns);
3236
3237   gfc_get_errors (NULL, &errors);
3238   if (s.state == COMP_MODULE)
3239     {
3240       gfc_dump_module (s.sym->name, errors_before == errors);
3241       if (errors == 0)
3242         gfc_generate_module_code (gfc_current_ns);
3243     }
3244   else
3245     {
3246       if (errors == 0)
3247         gfc_generate_code (gfc_current_ns);
3248     }
3249
3250   pop_state ();
3251   gfc_done_2 ();
3252   goto loop;
3253
3254 done:
3255   return SUCCESS;
3256
3257 duplicate_main:
3258   /* If we see a duplicate main program, shut down.  If the second
3259      instance is an implied main program, ie data decls or executable
3260      statements, we're in for lots of errors.  */
3261   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3262   reject_statement ();
3263   gfc_done_2 ();
3264   return SUCCESS;
3265 }