OSDN Git Service

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