OSDN Git Service

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