OSDN Git Service

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