OSDN Git Service

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