OSDN Git Service

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