OSDN Git Service

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