OSDN Git Service

aa16b22dd1e1bafaf9c03d9c22d3b6c88c98275b
[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;
1972   gfc_statement st;
1973   gfc_state_data s;
1974   gfc_symbol *sym;
1975   gfc_component *c;
1976
1977   accept_statement (ST_DERIVED_DECL);
1978   push_state (&s, COMP_DERIVED, gfc_new_block);
1979
1980   gfc_new_block->component_access = ACCESS_PUBLIC;
1981   seen_private = 0;
1982   seen_sequence = 0;
1983   seen_component = 0;
1984
1985   compiling_type = 1;
1986
1987   while (compiling_type)
1988     {
1989       st = next_statement ();
1990       switch (st)
1991         {
1992         case ST_NONE:
1993           unexpected_eof ();
1994
1995         case ST_DATA_DECL:
1996         case ST_PROCEDURE:
1997           accept_statement (st);
1998           seen_component = 1;
1999           break;
2000
2001         case ST_FINAL:
2002           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2003           break;
2004
2005         case ST_END_TYPE:
2006 endType:
2007           compiling_type = 0;
2008
2009           if (!seen_component)
2010             gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
2011                             "definition at %C without components");
2012
2013           accept_statement (ST_END_TYPE);
2014           break;
2015
2016         case ST_PRIVATE:
2017           if (gfc_find_state (COMP_MODULE) == FAILURE)
2018             {
2019               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2020                          "a MODULE");
2021               break;
2022             }
2023
2024           if (seen_component)
2025             {
2026               gfc_error ("PRIVATE statement at %C must precede "
2027                          "structure components");
2028               break;
2029             }
2030
2031           if (seen_private)
2032             gfc_error ("Duplicate PRIVATE statement at %C");
2033
2034           s.sym->component_access = ACCESS_PRIVATE;
2035
2036           accept_statement (ST_PRIVATE);
2037           seen_private = 1;
2038           break;
2039
2040         case ST_SEQUENCE:
2041           if (seen_component)
2042             {
2043               gfc_error ("SEQUENCE statement at %C must precede "
2044                          "structure components");
2045               break;
2046             }
2047
2048           if (gfc_current_block ()->attr.sequence)
2049             gfc_warning ("SEQUENCE attribute at %C already specified in "
2050                          "TYPE statement");
2051
2052           if (seen_sequence)
2053             {
2054               gfc_error ("Duplicate SEQUENCE statement at %C");
2055             }
2056
2057           seen_sequence = 1;
2058           gfc_add_sequence (&gfc_current_block ()->attr, 
2059                             gfc_current_block ()->name, NULL);
2060           break;
2061
2062         case ST_CONTAINS:
2063           gfc_notify_std (GFC_STD_F2003,
2064                           "Fortran 2003:  CONTAINS block in derived type"
2065                           " definition at %C");
2066
2067           accept_statement (ST_CONTAINS);
2068           parse_derived_contains ();
2069           goto endType;
2070
2071         default:
2072           unexpected_statement (st);
2073           break;
2074         }
2075     }
2076
2077   /* need to verify that all fields of the derived type are
2078    * interoperable with C if the type is declared to be bind(c)
2079    */
2080   sym = gfc_current_block ();
2081   for (c = sym->components; c; c = c->next)
2082     {
2083       /* Look for allocatable components.  */
2084       if (c->attr.allocatable
2085           || (c->ts.type == BT_CLASS
2086               && c->ts.u.derived->components->attr.allocatable)
2087           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2088         sym->attr.alloc_comp = 1;
2089
2090       /* Look for pointer components.  */
2091       if (c->attr.pointer
2092           || (c->ts.type == BT_CLASS
2093               && c->ts.u.derived->components->attr.pointer)
2094           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2095         sym->attr.pointer_comp = 1;
2096
2097       /* Look for procedure pointer components.  */
2098       if (c->attr.proc_pointer
2099           || (c->ts.type == BT_DERIVED
2100               && c->ts.u.derived->attr.proc_pointer_comp))
2101         sym->attr.proc_pointer_comp = 1;
2102
2103       /* Looking for coarray components.  */
2104       if (c->attr.codimension || c->attr.coarray_comp)
2105         sym->attr.coarray_comp = 1;
2106
2107       /* Look for private components.  */
2108       if (sym->component_access == ACCESS_PRIVATE
2109           || c->attr.access == ACCESS_PRIVATE
2110           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2111         sym->attr.private_comp = 1;
2112
2113      /* Fix up incomplete CLASS components.  */
2114      if (c->ts.type == BT_CLASS)
2115         {
2116           gfc_component *data;
2117           gfc_component *vptr;
2118           gfc_symbol *vtab;
2119           data = gfc_find_component (c->ts.u.derived, "$data", true, true);
2120           vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
2121           if (vptr->ts.u.derived == NULL)
2122             {
2123               vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
2124               gcc_assert (vtab);
2125               vptr->ts.u.derived = vtab->ts.u.derived;
2126             }
2127         }
2128     }
2129
2130   if (!seen_component)
2131     sym->attr.zero_comp = 1;
2132
2133   pop_state ();
2134 }
2135
2136
2137 /* Parse an ENUM.  */
2138  
2139 static void
2140 parse_enum (void)
2141 {
2142   gfc_statement st;
2143   int compiling_enum;
2144   gfc_state_data s;
2145   int seen_enumerator = 0;
2146
2147   push_state (&s, COMP_ENUM, gfc_new_block);
2148
2149   compiling_enum = 1;
2150
2151   while (compiling_enum)
2152     {
2153       st = next_statement ();
2154       switch (st)
2155         {
2156         case ST_NONE:
2157           unexpected_eof ();
2158           break;
2159
2160         case ST_ENUMERATOR:
2161           seen_enumerator = 1;
2162           accept_statement (st);
2163           break;
2164
2165         case ST_END_ENUM:
2166           compiling_enum = 0;
2167           if (!seen_enumerator)
2168             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2169           accept_statement (st);
2170           break;
2171
2172         default:
2173           gfc_free_enum_history ();
2174           unexpected_statement (st);
2175           break;
2176         }
2177     }
2178   pop_state ();
2179 }
2180
2181
2182 /* Parse an interface.  We must be able to deal with the possibility
2183    of recursive interfaces.  The parse_spec() subroutine is mutually
2184    recursive with parse_interface().  */
2185
2186 static gfc_statement parse_spec (gfc_statement);
2187
2188 static void
2189 parse_interface (void)
2190 {
2191   gfc_compile_state new_state = COMP_NONE, current_state;
2192   gfc_symbol *prog_unit, *sym;
2193   gfc_interface_info save;
2194   gfc_state_data s1, s2;
2195   gfc_statement st;
2196   locus proc_locus;
2197
2198   accept_statement (ST_INTERFACE);
2199
2200   current_interface.ns = gfc_current_ns;
2201   save = current_interface;
2202
2203   sym = (current_interface.type == INTERFACE_GENERIC
2204          || current_interface.type == INTERFACE_USER_OP)
2205         ? gfc_new_block : NULL;
2206
2207   push_state (&s1, COMP_INTERFACE, sym);
2208   current_state = COMP_NONE;
2209
2210 loop:
2211   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2212
2213   st = next_statement ();
2214   switch (st)
2215     {
2216     case ST_NONE:
2217       unexpected_eof ();
2218
2219     case ST_SUBROUTINE:
2220     case ST_FUNCTION:
2221       if (st == ST_SUBROUTINE)
2222         new_state = COMP_SUBROUTINE;
2223       else if (st == ST_FUNCTION)
2224         new_state = COMP_FUNCTION;
2225       if (gfc_new_block->attr.pointer)
2226         {
2227           gfc_new_block->attr.pointer = 0;
2228           gfc_new_block->attr.proc_pointer = 1;
2229         }
2230       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2231                                   gfc_new_block->formal, NULL) == FAILURE)
2232         {
2233           reject_statement ();
2234           gfc_free_namespace (gfc_current_ns);
2235           goto loop;
2236         }
2237       break;
2238
2239     case ST_PROCEDURE:
2240     case ST_MODULE_PROC:        /* The module procedure matcher makes
2241                                    sure the context is correct.  */
2242       accept_statement (st);
2243       gfc_free_namespace (gfc_current_ns);
2244       goto loop;
2245
2246     case ST_END_INTERFACE:
2247       gfc_free_namespace (gfc_current_ns);
2248       gfc_current_ns = current_interface.ns;
2249       goto done;
2250
2251     default:
2252       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2253                  gfc_ascii_statement (st));
2254       reject_statement ();
2255       gfc_free_namespace (gfc_current_ns);
2256       goto loop;
2257     }
2258
2259
2260   /* Make sure that a generic interface has only subroutines or
2261      functions and that the generic name has the right attribute.  */
2262   if (current_interface.type == INTERFACE_GENERIC)
2263     {
2264       if (current_state == COMP_NONE)
2265         {
2266           if (new_state == COMP_FUNCTION && sym)
2267             gfc_add_function (&sym->attr, sym->name, NULL);
2268           else if (new_state == COMP_SUBROUTINE && sym)
2269             gfc_add_subroutine (&sym->attr, sym->name, NULL);
2270
2271           current_state = new_state;
2272         }
2273       else
2274         {
2275           if (new_state != current_state)
2276             {
2277               if (new_state == COMP_SUBROUTINE)
2278                 gfc_error ("SUBROUTINE at %C does not belong in a "
2279                            "generic function interface");
2280
2281               if (new_state == COMP_FUNCTION)
2282                 gfc_error ("FUNCTION at %C does not belong in a "
2283                            "generic subroutine interface");
2284             }
2285         }
2286     }
2287
2288   if (current_interface.type == INTERFACE_ABSTRACT)
2289     {
2290       gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2291       if (gfc_is_intrinsic_typename (gfc_new_block->name))
2292         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2293                    "cannot be the same as an intrinsic type",
2294                    gfc_new_block->name);
2295     }
2296
2297   push_state (&s2, new_state, gfc_new_block);
2298   accept_statement (st);
2299   prog_unit = gfc_new_block;
2300   prog_unit->formal_ns = gfc_current_ns;
2301   proc_locus = gfc_current_locus;
2302
2303 decl:
2304   /* Read data declaration statements.  */
2305   st = parse_spec (ST_NONE);
2306
2307   /* Since the interface block does not permit an IMPLICIT statement,
2308      the default type for the function or the result must be taken
2309      from the formal namespace.  */
2310   if (new_state == COMP_FUNCTION)
2311     {
2312         if (prog_unit->result == prog_unit
2313               && prog_unit->ts.type == BT_UNKNOWN)
2314           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2315         else if (prog_unit->result != prog_unit
2316                    && prog_unit->result->ts.type == BT_UNKNOWN)
2317           gfc_set_default_type (prog_unit->result, 1,
2318                                 prog_unit->formal_ns);
2319     }
2320
2321   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2322     {
2323       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2324                  gfc_ascii_statement (st));
2325       reject_statement ();
2326       goto decl;
2327     }
2328
2329   /* Add EXTERNAL attribute to function or subroutine.  */
2330   if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2331     gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2332
2333   current_interface = save;
2334   gfc_add_interface (prog_unit);
2335   pop_state ();
2336
2337   if (current_interface.ns
2338         && current_interface.ns->proc_name
2339         && strcmp (current_interface.ns->proc_name->name,
2340                    prog_unit->name) == 0)
2341     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2342                "enclosing procedure", prog_unit->name, &proc_locus);
2343
2344   goto loop;
2345
2346 done:
2347   pop_state ();
2348 }
2349
2350
2351 /* Associate function characteristics by going back to the function
2352    declaration and rematching the prefix.  */
2353
2354 static match
2355 match_deferred_characteristics (gfc_typespec * ts)
2356 {
2357   locus loc;
2358   match m = MATCH_ERROR;
2359   char name[GFC_MAX_SYMBOL_LEN + 1];
2360
2361   loc = gfc_current_locus;
2362
2363   gfc_current_locus = gfc_current_block ()->declared_at;
2364
2365   gfc_clear_error ();
2366   gfc_buffer_error (1);
2367   m = gfc_match_prefix (ts);
2368   gfc_buffer_error (0);
2369
2370   if (ts->type == BT_DERIVED)
2371     {
2372       ts->kind = 0;
2373
2374       if (!ts->u.derived)
2375         m = MATCH_ERROR;
2376     }
2377
2378   /* Only permit one go at the characteristic association.  */
2379   if (ts->kind == -1)
2380     ts->kind = 0;
2381
2382   /* Set the function locus correctly.  If we have not found the
2383      function name, there is an error.  */
2384   if (m == MATCH_YES
2385       && gfc_match ("function% %n", name) == MATCH_YES
2386       && strcmp (name, gfc_current_block ()->name) == 0)
2387     {
2388       gfc_current_block ()->declared_at = gfc_current_locus;
2389       gfc_commit_symbols ();
2390     }
2391   else
2392     gfc_error_check ();
2393
2394   gfc_current_locus =loc;
2395   return m;
2396 }
2397
2398
2399 /* Check specification-expressions in the function result of the currently
2400    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2401    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2402    scope are not yet parsed so this has to be delayed up to parse_spec.  */
2403
2404 static void
2405 check_function_result_typed (void)
2406 {
2407   gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2408
2409   gcc_assert (gfc_current_state () == COMP_FUNCTION);
2410   gcc_assert (ts->type != BT_UNKNOWN);
2411
2412   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
2413   /* TODO:  Extend when KIND type parameters are implemented.  */
2414   if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2415     gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2416 }
2417
2418
2419 /* Parse a set of specification statements.  Returns the statement
2420    that doesn't fit.  */
2421
2422 static gfc_statement
2423 parse_spec (gfc_statement st)
2424 {
2425   st_state ss;
2426   bool function_result_typed = false;
2427   bool bad_characteristic = false;
2428   gfc_typespec *ts;
2429
2430   verify_st_order (&ss, ST_NONE, false);
2431   if (st == ST_NONE)
2432     st = next_statement ();
2433
2434   /* If we are not inside a function or don't have a result specified so far,
2435      do nothing special about it.  */
2436   if (gfc_current_state () != COMP_FUNCTION)
2437     function_result_typed = true;
2438   else
2439     {
2440       gfc_symbol* proc = gfc_current_ns->proc_name;
2441       gcc_assert (proc);
2442
2443       if (proc->result->ts.type == BT_UNKNOWN)
2444         function_result_typed = true;
2445     }
2446
2447 loop:
2448
2449   /* If we're inside a BLOCK construct, some statements are disallowed.
2450      Check this here.  Attribute declaration statements like INTENT, OPTIONAL
2451      or VALUE are also disallowed, but they don't have a particular ST_*
2452      key so we have to check for them individually in their matcher routine.  */
2453   if (gfc_current_state () == COMP_BLOCK)
2454     switch (st)
2455       {
2456         case ST_IMPLICIT:
2457         case ST_IMPLICIT_NONE:
2458         case ST_NAMELIST:
2459         case ST_COMMON:
2460         case ST_EQUIVALENCE:
2461         case ST_STATEMENT_FUNCTION:
2462           gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2463                      gfc_ascii_statement (st));
2464           break;
2465
2466         default:
2467           break;
2468       }
2469   
2470   /* If we find a statement that can not be followed by an IMPLICIT statement
2471      (and thus we can expect to see none any further), type the function result
2472      if it has not yet been typed.  Be careful not to give the END statement
2473      to verify_st_order!  */
2474   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2475     {
2476       bool verify_now = false;
2477
2478       if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2479         verify_now = true;
2480       else
2481         {
2482           st_state dummyss;
2483           verify_st_order (&dummyss, ST_NONE, false);
2484           verify_st_order (&dummyss, st, false);
2485
2486           if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2487             verify_now = true;
2488         }
2489
2490       if (verify_now)
2491         {
2492           check_function_result_typed ();
2493           function_result_typed = true;
2494         }
2495     }
2496
2497   switch (st)
2498     {
2499     case ST_NONE:
2500       unexpected_eof ();
2501
2502     case ST_IMPLICIT_NONE:
2503     case ST_IMPLICIT:
2504       if (!function_result_typed)
2505         {
2506           check_function_result_typed ();
2507           function_result_typed = true;
2508         }
2509       goto declSt;
2510
2511     case ST_FORMAT:
2512     case ST_ENTRY:
2513     case ST_DATA:       /* Not allowed in interfaces */
2514       if (gfc_current_state () == COMP_INTERFACE)
2515         break;
2516
2517       /* Fall through */
2518
2519     case ST_USE:
2520     case ST_IMPORT:
2521     case ST_PARAMETER:
2522     case ST_PUBLIC:
2523     case ST_PRIVATE:
2524     case ST_DERIVED_DECL:
2525     case_decl:
2526 declSt:
2527       if (verify_st_order (&ss, st, false) == FAILURE)
2528         {
2529           reject_statement ();
2530           st = next_statement ();
2531           goto loop;
2532         }
2533
2534       switch (st)
2535         {
2536         case ST_INTERFACE:
2537           parse_interface ();
2538           break;
2539
2540         case ST_DERIVED_DECL:
2541           parse_derived ();
2542           break;
2543
2544         case ST_PUBLIC:
2545         case ST_PRIVATE:
2546           if (gfc_current_state () != COMP_MODULE)
2547             {
2548               gfc_error ("%s statement must appear in a MODULE",
2549                          gfc_ascii_statement (st));
2550               break;
2551             }
2552
2553           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2554             {
2555               gfc_error ("%s statement at %C follows another accessibility "
2556                          "specification", gfc_ascii_statement (st));
2557               break;
2558             }
2559
2560           gfc_current_ns->default_access = (st == ST_PUBLIC)
2561             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2562
2563           break;
2564
2565         case ST_STATEMENT_FUNCTION:
2566           if (gfc_current_state () == COMP_MODULE)
2567             {
2568               unexpected_statement (st);
2569               break;
2570             }
2571
2572         default:
2573           break;
2574         }
2575
2576       accept_statement (st);
2577       st = next_statement ();
2578       goto loop;
2579
2580     case ST_ENUM:
2581       accept_statement (st);
2582       parse_enum();
2583       st = next_statement ();
2584       goto loop;
2585
2586     case ST_GET_FCN_CHARACTERISTICS:
2587       /* This statement triggers the association of a function's result
2588          characteristics.  */
2589       ts = &gfc_current_block ()->result->ts;
2590       if (match_deferred_characteristics (ts) != MATCH_YES)
2591         bad_characteristic = true;
2592
2593       st = next_statement ();
2594       goto loop;
2595
2596     default:
2597       break;
2598     }
2599
2600   /* If match_deferred_characteristics failed, then there is an error. */
2601   if (bad_characteristic)
2602     {
2603       ts = &gfc_current_block ()->result->ts;
2604       if (ts->type != BT_DERIVED)
2605         gfc_error ("Bad kind expression for function '%s' at %L",
2606                    gfc_current_block ()->name,
2607                    &gfc_current_block ()->declared_at);
2608       else
2609         gfc_error ("The type for function '%s' at %L is not accessible",
2610                    gfc_current_block ()->name,
2611                    &gfc_current_block ()->declared_at);
2612
2613       gfc_current_block ()->ts.kind = 0;
2614       /* Keep the derived type; if it's bad, it will be discovered later.  */
2615       if (!(ts->type == BT_DERIVED && ts->u.derived))
2616         ts->type = BT_UNKNOWN;
2617     }
2618
2619   return st;
2620 }
2621
2622
2623 /* Parse a WHERE block, (not a simple WHERE statement).  */
2624
2625 static void
2626 parse_where_block (void)
2627 {
2628   int seen_empty_else;
2629   gfc_code *top, *d;
2630   gfc_state_data s;
2631   gfc_statement st;
2632
2633   accept_statement (ST_WHERE_BLOCK);
2634   top = gfc_state_stack->tail;
2635
2636   push_state (&s, COMP_WHERE, gfc_new_block);
2637
2638   d = add_statement ();
2639   d->expr1 = top->expr1;
2640   d->op = EXEC_WHERE;
2641
2642   top->expr1 = NULL;
2643   top->block = d;
2644
2645   seen_empty_else = 0;
2646
2647   do
2648     {
2649       st = next_statement ();
2650       switch (st)
2651         {
2652         case ST_NONE:
2653           unexpected_eof ();
2654
2655         case ST_WHERE_BLOCK:
2656           parse_where_block ();
2657           break;
2658
2659         case ST_ASSIGNMENT:
2660         case ST_WHERE:
2661           accept_statement (st);
2662           break;
2663
2664         case ST_ELSEWHERE:
2665           if (seen_empty_else)
2666             {
2667               gfc_error ("ELSEWHERE statement at %C follows previous "
2668                          "unmasked ELSEWHERE");
2669               break;
2670             }
2671
2672           if (new_st.expr1 == NULL)
2673             seen_empty_else = 1;
2674
2675           d = new_level (gfc_state_stack->head);
2676           d->op = EXEC_WHERE;
2677           d->expr1 = new_st.expr1;
2678
2679           accept_statement (st);
2680
2681           break;
2682
2683         case ST_END_WHERE:
2684           accept_statement (st);
2685           break;
2686
2687         default:
2688           gfc_error ("Unexpected %s statement in WHERE block at %C",
2689                      gfc_ascii_statement (st));
2690           reject_statement ();
2691           break;
2692         }
2693     }
2694   while (st != ST_END_WHERE);
2695
2696   pop_state ();
2697 }
2698
2699
2700 /* Parse a FORALL block (not a simple FORALL statement).  */
2701
2702 static void
2703 parse_forall_block (void)
2704 {
2705   gfc_code *top, *d;
2706   gfc_state_data s;
2707   gfc_statement st;
2708
2709   accept_statement (ST_FORALL_BLOCK);
2710   top = gfc_state_stack->tail;
2711
2712   push_state (&s, COMP_FORALL, gfc_new_block);
2713
2714   d = add_statement ();
2715   d->op = EXEC_FORALL;
2716   top->block = d;
2717
2718   do
2719     {
2720       st = next_statement ();
2721       switch (st)
2722         {
2723
2724         case ST_ASSIGNMENT:
2725         case ST_POINTER_ASSIGNMENT:
2726         case ST_WHERE:
2727         case ST_FORALL:
2728           accept_statement (st);
2729           break;
2730
2731         case ST_WHERE_BLOCK:
2732           parse_where_block ();
2733           break;
2734
2735         case ST_FORALL_BLOCK:
2736           parse_forall_block ();
2737           break;
2738
2739         case ST_END_FORALL:
2740           accept_statement (st);
2741           break;
2742
2743         case ST_NONE:
2744           unexpected_eof ();
2745
2746         default:
2747           gfc_error ("Unexpected %s statement in FORALL block at %C",
2748                      gfc_ascii_statement (st));
2749
2750           reject_statement ();
2751           break;
2752         }
2753     }
2754   while (st != ST_END_FORALL);
2755
2756   pop_state ();
2757 }
2758
2759
2760 static gfc_statement parse_executable (gfc_statement);
2761
2762 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2763
2764 static void
2765 parse_if_block (void)
2766 {
2767   gfc_code *top, *d;
2768   gfc_statement st;
2769   locus else_locus;
2770   gfc_state_data s;
2771   int seen_else;
2772
2773   seen_else = 0;
2774   accept_statement (ST_IF_BLOCK);
2775
2776   top = gfc_state_stack->tail;
2777   push_state (&s, COMP_IF, gfc_new_block);
2778
2779   new_st.op = EXEC_IF;
2780   d = add_statement ();
2781
2782   d->expr1 = top->expr1;
2783   top->expr1 = NULL;
2784   top->block = d;
2785
2786   do
2787     {
2788       st = parse_executable (ST_NONE);
2789
2790       switch (st)
2791         {
2792         case ST_NONE:
2793           unexpected_eof ();
2794
2795         case ST_ELSEIF:
2796           if (seen_else)
2797             {
2798               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2799                          "statement at %L", &else_locus);
2800
2801               reject_statement ();
2802               break;
2803             }
2804
2805           d = new_level (gfc_state_stack->head);
2806           d->op = EXEC_IF;
2807           d->expr1 = new_st.expr1;
2808
2809           accept_statement (st);
2810
2811           break;
2812
2813         case ST_ELSE:
2814           if (seen_else)
2815             {
2816               gfc_error ("Duplicate ELSE statements at %L and %C",
2817                          &else_locus);
2818               reject_statement ();
2819               break;
2820             }
2821
2822           seen_else = 1;
2823           else_locus = gfc_current_locus;
2824
2825           d = new_level (gfc_state_stack->head);
2826           d->op = EXEC_IF;
2827
2828           accept_statement (st);
2829
2830           break;
2831
2832         case ST_ENDIF:
2833           break;
2834
2835         default:
2836           unexpected_statement (st);
2837           break;
2838         }
2839     }
2840   while (st != ST_ENDIF);
2841
2842   pop_state ();
2843   accept_statement (st);
2844 }
2845
2846
2847 /* Parse a SELECT block.  */
2848
2849 static void
2850 parse_select_block (void)
2851 {
2852   gfc_statement st;
2853   gfc_code *cp;
2854   gfc_state_data s;
2855
2856   accept_statement (ST_SELECT_CASE);
2857
2858   cp = gfc_state_stack->tail;
2859   push_state (&s, COMP_SELECT, gfc_new_block);
2860
2861   /* Make sure that the next statement is a CASE or END SELECT.  */
2862   for (;;)
2863     {
2864       st = next_statement ();
2865       if (st == ST_NONE)
2866         unexpected_eof ();
2867       if (st == ST_END_SELECT)
2868         {
2869           /* Empty SELECT CASE is OK.  */
2870           accept_statement (st);
2871           pop_state ();
2872           return;
2873         }
2874       if (st == ST_CASE)
2875         break;
2876
2877       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2878                  "CASE at %C");
2879
2880       reject_statement ();
2881     }
2882
2883   /* At this point, we're got a nonempty select block.  */
2884   cp = new_level (cp);
2885   *cp = new_st;
2886
2887   accept_statement (st);
2888
2889   do
2890     {
2891       st = parse_executable (ST_NONE);
2892       switch (st)
2893         {
2894         case ST_NONE:
2895           unexpected_eof ();
2896
2897         case ST_CASE:
2898           cp = new_level (gfc_state_stack->head);
2899           *cp = new_st;
2900           gfc_clear_new_st ();
2901
2902           accept_statement (st);
2903           /* Fall through */
2904
2905         case ST_END_SELECT:
2906           break;
2907
2908         /* Can't have an executable statement because of
2909            parse_executable().  */
2910         default:
2911           unexpected_statement (st);
2912           break;
2913         }
2914     }
2915   while (st != ST_END_SELECT);
2916
2917   pop_state ();
2918   accept_statement (st);
2919 }
2920
2921
2922 /* Pop the current selector from the SELECT TYPE stack.  */
2923
2924 static void
2925 select_type_pop (void)
2926 {
2927   gfc_select_type_stack *old = select_type_stack;
2928   select_type_stack = old->prev;
2929   gfc_free (old);
2930 }
2931
2932
2933 /* Parse a SELECT TYPE construct (F03:R821).  */
2934
2935 static void
2936 parse_select_type_block (void)
2937 {
2938   gfc_statement st;
2939   gfc_code *cp;
2940   gfc_state_data s;
2941
2942   accept_statement (ST_SELECT_TYPE);
2943
2944   cp = gfc_state_stack->tail;
2945   push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
2946
2947   /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2948      or END SELECT.  */
2949   for (;;)
2950     {
2951       st = next_statement ();
2952       if (st == ST_NONE)
2953         unexpected_eof ();
2954       if (st == ST_END_SELECT)
2955         /* Empty SELECT CASE is OK.  */
2956         goto done;
2957       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
2958         break;
2959
2960       gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2961                  "following SELECT TYPE at %C");
2962
2963       reject_statement ();
2964     }
2965
2966   /* At this point, we're got a nonempty select block.  */
2967   cp = new_level (cp);
2968   *cp = new_st;
2969
2970   accept_statement (st);
2971
2972   do
2973     {
2974       st = parse_executable (ST_NONE);
2975       switch (st)
2976         {
2977         case ST_NONE:
2978           unexpected_eof ();
2979
2980         case ST_TYPE_IS:
2981         case ST_CLASS_IS:
2982           cp = new_level (gfc_state_stack->head);
2983           *cp = new_st;
2984           gfc_clear_new_st ();
2985
2986           accept_statement (st);
2987           /* Fall through */
2988
2989         case ST_END_SELECT:
2990           break;
2991
2992         /* Can't have an executable statement because of
2993            parse_executable().  */
2994         default:
2995           unexpected_statement (st);
2996           break;
2997         }
2998     }
2999   while (st != ST_END_SELECT);
3000
3001 done:
3002   pop_state ();
3003   accept_statement (st);
3004   gfc_current_ns = gfc_current_ns->parent;
3005   select_type_pop ();
3006 }
3007
3008
3009 /* Given a symbol, make sure it is not an iteration variable for a DO
3010    statement.  This subroutine is called when the symbol is seen in a
3011    context that causes it to become redefined.  If the symbol is an
3012    iterator, we generate an error message and return nonzero.  */
3013
3014 int 
3015 gfc_check_do_variable (gfc_symtree *st)
3016 {
3017   gfc_state_data *s;
3018
3019   for (s=gfc_state_stack; s; s = s->previous)
3020     if (s->do_variable == st)
3021       {
3022         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3023                       "loop beginning at %L", st->name, &s->head->loc);
3024         return 1;
3025       }
3026
3027   return 0;
3028 }
3029   
3030
3031 /* Checks to see if the current statement label closes an enddo.
3032    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3033    an error) if it incorrectly closes an ENDDO.  */
3034
3035 static int
3036 check_do_closure (void)
3037 {
3038   gfc_state_data *p;
3039
3040   if (gfc_statement_label == NULL)
3041     return 0;
3042
3043   for (p = gfc_state_stack; p; p = p->previous)
3044     if (p->state == COMP_DO)
3045       break;
3046
3047   if (p == NULL)
3048     return 0;           /* No loops to close */
3049
3050   if (p->ext.end_do_label == gfc_statement_label)
3051     {
3052       if (p == gfc_state_stack)
3053         return 1;
3054
3055       gfc_error ("End of nonblock DO statement at %C is within another block");
3056       return 2;
3057     }
3058
3059   /* At this point, the label doesn't terminate the innermost loop.
3060      Make sure it doesn't terminate another one.  */
3061   for (; p; p = p->previous)
3062     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
3063       {
3064         gfc_error ("End of nonblock DO statement at %C is interwoven "
3065                    "with another DO loop");
3066         return 2;
3067       }
3068
3069   return 0;
3070 }
3071
3072
3073 /* Parse a series of contained program units.  */
3074
3075 static void parse_progunit (gfc_statement);
3076
3077
3078 /* Parse a CRITICAL block.  */
3079
3080 static void
3081 parse_critical_block (void)
3082 {
3083   gfc_code *top, *d;
3084   gfc_state_data s;
3085   gfc_statement st;
3086
3087   s.ext.end_do_label = new_st.label1;
3088
3089   accept_statement (ST_CRITICAL);
3090   top = gfc_state_stack->tail;
3091
3092   push_state (&s, COMP_CRITICAL, gfc_new_block);
3093
3094   d = add_statement ();
3095   d->op = EXEC_CRITICAL;
3096   top->block = d;
3097
3098   do
3099     {
3100       st = parse_executable (ST_NONE);
3101
3102       switch (st)
3103         {
3104           case ST_NONE:
3105             unexpected_eof ();
3106             break;
3107
3108           case ST_END_CRITICAL:
3109             if (s.ext.end_do_label != NULL
3110                 && s.ext.end_do_label != gfc_statement_label)
3111               gfc_error_now ("Statement label in END CRITICAL at %C does not "
3112                              "match CRITIAL label");
3113
3114             if (gfc_statement_label != NULL)
3115               {
3116                 new_st.op = EXEC_NOP;
3117                 add_statement ();
3118               }
3119             break;
3120
3121           default:
3122             unexpected_statement (st);
3123             break;
3124         }
3125     }
3126   while (st != ST_END_CRITICAL);
3127
3128   pop_state ();
3129   accept_statement (st);
3130 }
3131
3132
3133 /* Set up the local namespace for a BLOCK construct.  */
3134
3135 gfc_namespace*
3136 gfc_build_block_ns (gfc_namespace *parent_ns)
3137 {
3138   gfc_namespace* my_ns;
3139
3140   my_ns = gfc_get_namespace (parent_ns, 1);
3141   my_ns->construct_entities = 1;
3142
3143   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3144      code generation (so it must not be NULL).
3145      We set its recursive argument if our container procedure is recursive, so
3146      that local variables are accordingly placed on the stack when it
3147      will be necessary.  */
3148   if (gfc_new_block)
3149     my_ns->proc_name = gfc_new_block;
3150   else
3151     {
3152       gfc_try t;
3153
3154       gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
3155       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3156                           my_ns->proc_name->name, NULL);
3157       gcc_assert (t == SUCCESS);
3158     }
3159
3160   if (parent_ns->proc_name)
3161     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3162
3163   return my_ns;
3164 }
3165
3166
3167 /* Parse a BLOCK construct.  */
3168
3169 static void
3170 parse_block_construct (void)
3171 {
3172   gfc_namespace* my_ns;
3173   gfc_state_data s;
3174
3175   gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3176
3177   my_ns = gfc_build_block_ns (gfc_current_ns);
3178
3179   new_st.op = EXEC_BLOCK;
3180   new_st.ext.ns = my_ns;
3181   accept_statement (ST_BLOCK);
3182
3183   push_state (&s, COMP_BLOCK, my_ns->proc_name);
3184   gfc_current_ns = my_ns;
3185
3186   parse_progunit (ST_NONE);
3187
3188   gfc_current_ns = gfc_current_ns->parent;
3189   pop_state ();
3190 }
3191
3192
3193 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
3194    handled inside of parse_executable(), because they aren't really
3195    loop statements.  */
3196
3197 static void
3198 parse_do_block (void)
3199 {
3200   gfc_statement st;
3201   gfc_code *top;
3202   gfc_state_data s;
3203   gfc_symtree *stree;
3204
3205   s.ext.end_do_label = new_st.label1;
3206
3207   if (new_st.ext.iterator != NULL)
3208     stree = new_st.ext.iterator->var->symtree;
3209   else
3210     stree = NULL;
3211
3212   accept_statement (ST_DO);
3213
3214   top = gfc_state_stack->tail;
3215   push_state (&s, COMP_DO, gfc_new_block);
3216
3217   s.do_variable = stree;
3218
3219   top->block = new_level (top);
3220   top->block->op = EXEC_DO;
3221
3222 loop:
3223   st = parse_executable (ST_NONE);
3224
3225   switch (st)
3226     {
3227     case ST_NONE:
3228       unexpected_eof ();
3229
3230     case ST_ENDDO:
3231       if (s.ext.end_do_label != NULL
3232           && s.ext.end_do_label != gfc_statement_label)
3233         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3234                        "DO label");
3235
3236       if (gfc_statement_label != NULL)
3237         {
3238           new_st.op = EXEC_NOP;
3239           add_statement ();
3240         }
3241       break;
3242
3243     case ST_IMPLIED_ENDDO:
3244      /* If the do-stmt of this DO construct has a do-construct-name,
3245         the corresponding end-do must be an end-do-stmt (with a matching
3246         name, but in that case we must have seen ST_ENDDO first).
3247         We only complain about this in pedantic mode.  */
3248      if (gfc_current_block () != NULL)
3249         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3250                        &gfc_current_block()->declared_at);
3251
3252       break;
3253
3254     default:
3255       unexpected_statement (st);
3256       goto loop;
3257     }
3258
3259   pop_state ();
3260   accept_statement (st);
3261 }
3262
3263
3264 /* Parse the statements of OpenMP do/parallel do.  */
3265
3266 static gfc_statement
3267 parse_omp_do (gfc_statement omp_st)
3268 {
3269   gfc_statement st;
3270   gfc_code *cp, *np;
3271   gfc_state_data s;
3272
3273   accept_statement (omp_st);
3274
3275   cp = gfc_state_stack->tail;
3276   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3277   np = new_level (cp);
3278   np->op = cp->op;
3279   np->block = NULL;
3280
3281   for (;;)
3282     {
3283       st = next_statement ();
3284       if (st == ST_NONE)
3285         unexpected_eof ();
3286       else if (st == ST_DO)
3287         break;
3288       else
3289         unexpected_statement (st);
3290     }
3291
3292   parse_do_block ();
3293   if (gfc_statement_label != NULL
3294       && gfc_state_stack->previous != NULL
3295       && gfc_state_stack->previous->state == COMP_DO
3296       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3297     {
3298       /* In
3299          DO 100 I=1,10
3300            !$OMP DO
3301              DO J=1,10
3302              ...
3303              100 CONTINUE
3304          there should be no !$OMP END DO.  */
3305       pop_state ();
3306       return ST_IMPLIED_ENDDO;
3307     }
3308
3309   check_do_closure ();
3310   pop_state ();
3311
3312   st = next_statement ();
3313   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3314     {
3315       if (new_st.op == EXEC_OMP_END_NOWAIT)
3316         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3317       else
3318         gcc_assert (new_st.op == EXEC_NOP);
3319       gfc_clear_new_st ();
3320       gfc_commit_symbols ();
3321       gfc_warning_check ();
3322       st = next_statement ();
3323     }
3324   return st;
3325 }
3326
3327
3328 /* Parse the statements of OpenMP atomic directive.  */
3329
3330 static void
3331 parse_omp_atomic (void)
3332 {
3333   gfc_statement st;
3334   gfc_code *cp, *np;
3335   gfc_state_data s;
3336
3337   accept_statement (ST_OMP_ATOMIC);
3338
3339   cp = gfc_state_stack->tail;
3340   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3341   np = new_level (cp);
3342   np->op = cp->op;
3343   np->block = NULL;
3344
3345   for (;;)
3346     {
3347       st = next_statement ();
3348       if (st == ST_NONE)
3349         unexpected_eof ();
3350       else if (st == ST_ASSIGNMENT)
3351         break;
3352       else
3353         unexpected_statement (st);
3354     }
3355
3356   accept_statement (st);
3357
3358   pop_state ();
3359 }
3360
3361
3362 /* Parse the statements of an OpenMP structured block.  */
3363
3364 static void
3365 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3366 {
3367   gfc_statement st, omp_end_st;
3368   gfc_code *cp, *np;
3369   gfc_state_data s;
3370
3371   accept_statement (omp_st);
3372
3373   cp = gfc_state_stack->tail;
3374   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3375   np = new_level (cp);
3376   np->op = cp->op;
3377   np->block = NULL;
3378
3379   switch (omp_st)
3380     {
3381     case ST_OMP_PARALLEL:
3382       omp_end_st = ST_OMP_END_PARALLEL;
3383       break;
3384     case ST_OMP_PARALLEL_SECTIONS:
3385       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3386       break;
3387     case ST_OMP_SECTIONS:
3388       omp_end_st = ST_OMP_END_SECTIONS;
3389       break;
3390     case ST_OMP_ORDERED:
3391       omp_end_st = ST_OMP_END_ORDERED;
3392       break;
3393     case ST_OMP_CRITICAL:
3394       omp_end_st = ST_OMP_END_CRITICAL;
3395       break;
3396     case ST_OMP_MASTER:
3397       omp_end_st = ST_OMP_END_MASTER;
3398       break;
3399     case ST_OMP_SINGLE:
3400       omp_end_st = ST_OMP_END_SINGLE;
3401       break;
3402     case ST_OMP_TASK:
3403       omp_end_st = ST_OMP_END_TASK;
3404       break;
3405     case ST_OMP_WORKSHARE:
3406       omp_end_st = ST_OMP_END_WORKSHARE;
3407       break;
3408     case ST_OMP_PARALLEL_WORKSHARE:
3409       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3410       break;
3411     default:
3412       gcc_unreachable ();
3413     }
3414
3415   do
3416     {
3417       if (workshare_stmts_only)
3418         {
3419           /* Inside of !$omp workshare, only
3420              scalar assignments
3421              array assignments
3422              where statements and constructs
3423              forall statements and constructs
3424              !$omp atomic
3425              !$omp critical
3426              !$omp parallel
3427              are allowed.  For !$omp critical these
3428              restrictions apply recursively.  */
3429           bool cycle = true;
3430
3431           st = next_statement ();
3432           for (;;)
3433             {
3434               switch (st)
3435                 {
3436                 case ST_NONE:
3437                   unexpected_eof ();
3438
3439                 case ST_ASSIGNMENT:
3440                 case ST_WHERE:
3441                 case ST_FORALL:
3442                   accept_statement (st);
3443                   break;
3444
3445                 case ST_WHERE_BLOCK:
3446                   parse_where_block ();
3447                   break;
3448
3449                 case ST_FORALL_BLOCK:
3450                   parse_forall_block ();
3451                   break;
3452
3453                 case ST_OMP_PARALLEL:
3454                 case ST_OMP_PARALLEL_SECTIONS:
3455                   parse_omp_structured_block (st, false);
3456                   break;
3457
3458                 case ST_OMP_PARALLEL_WORKSHARE:
3459                 case ST_OMP_CRITICAL:
3460                   parse_omp_structured_block (st, true);
3461                   break;
3462
3463                 case ST_OMP_PARALLEL_DO:
3464                   st = parse_omp_do (st);
3465                   continue;
3466
3467                 case ST_OMP_ATOMIC:
3468                   parse_omp_atomic ();
3469                   break;
3470
3471                 default:
3472                   cycle = false;
3473                   break;
3474                 }
3475
3476               if (!cycle)
3477                 break;
3478
3479               st = next_statement ();
3480             }
3481         }
3482       else
3483         st = parse_executable (ST_NONE);
3484       if (st == ST_NONE)
3485         unexpected_eof ();
3486       else if (st == ST_OMP_SECTION
3487                && (omp_st == ST_OMP_SECTIONS
3488                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
3489         {
3490           np = new_level (np);
3491           np->op = cp->op;
3492           np->block = NULL;
3493         }
3494       else if (st != omp_end_st)
3495         unexpected_statement (st);
3496     }
3497   while (st != omp_end_st);
3498
3499   switch (new_st.op)
3500     {
3501     case EXEC_OMP_END_NOWAIT:
3502       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3503       break;
3504     case EXEC_OMP_CRITICAL:
3505       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3506           || (new_st.ext.omp_name != NULL
3507               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3508         gfc_error ("Name after !$omp critical and !$omp end critical does "
3509                    "not match at %C");
3510       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3511       break;
3512     case EXEC_OMP_END_SINGLE:
3513       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3514         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3515       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3516       gfc_free_omp_clauses (new_st.ext.omp_clauses);
3517       break;
3518     case EXEC_NOP:
3519       break;
3520     default:
3521       gcc_unreachable ();
3522     }
3523
3524   gfc_clear_new_st ();
3525   gfc_commit_symbols ();
3526   gfc_warning_check ();
3527   pop_state ();
3528 }
3529
3530
3531 /* Accept a series of executable statements.  We return the first
3532    statement that doesn't fit to the caller.  Any block statements are
3533    passed on to the correct handler, which usually passes the buck
3534    right back here.  */
3535
3536 static gfc_statement
3537 parse_executable (gfc_statement st)
3538 {
3539   int close_flag;
3540
3541   if (st == ST_NONE)
3542     st = next_statement ();
3543
3544   for (;;)
3545     {
3546       close_flag = check_do_closure ();
3547       if (close_flag)
3548         switch (st)
3549           {
3550           case ST_GOTO:
3551           case ST_END_PROGRAM:
3552           case ST_RETURN:
3553           case ST_EXIT:
3554           case ST_END_FUNCTION:
3555           case ST_CYCLE:
3556           case ST_PAUSE:
3557           case ST_STOP:
3558           case ST_ERROR_STOP:
3559           case ST_END_SUBROUTINE:
3560
3561           case ST_DO:
3562           case ST_CRITICAL:
3563           case ST_BLOCK:
3564           case ST_FORALL:
3565           case ST_WHERE:
3566           case ST_SELECT_CASE:
3567             gfc_error ("%s statement at %C cannot terminate a non-block "
3568                        "DO loop", gfc_ascii_statement (st));
3569             break;
3570
3571           default:
3572             break;
3573           }
3574
3575       switch (st)
3576         {
3577         case ST_NONE:
3578           unexpected_eof ();
3579
3580         case ST_FORMAT:
3581         case ST_DATA:
3582         case ST_ENTRY:
3583         case_executable:
3584           accept_statement (st);
3585           if (close_flag == 1)
3586             return ST_IMPLIED_ENDDO;
3587           break;
3588
3589         case ST_BLOCK:
3590           parse_block_construct ();
3591           break;
3592
3593         case ST_IF_BLOCK:
3594           parse_if_block ();
3595           break;
3596
3597         case ST_SELECT_CASE:
3598           parse_select_block ();
3599           break;
3600
3601         case ST_SELECT_TYPE:
3602           parse_select_type_block();
3603           break;
3604
3605         case ST_DO:
3606           parse_do_block ();
3607           if (check_do_closure () == 1)
3608             return ST_IMPLIED_ENDDO;
3609           break;
3610
3611         case ST_CRITICAL:
3612           parse_critical_block ();
3613           break;
3614
3615         case ST_WHERE_BLOCK:
3616           parse_where_block ();
3617           break;
3618
3619         case ST_FORALL_BLOCK:
3620           parse_forall_block ();
3621           break;
3622
3623         case ST_OMP_PARALLEL:
3624         case ST_OMP_PARALLEL_SECTIONS:
3625         case ST_OMP_SECTIONS:
3626         case ST_OMP_ORDERED:
3627         case ST_OMP_CRITICAL:
3628         case ST_OMP_MASTER:
3629         case ST_OMP_SINGLE:
3630         case ST_OMP_TASK:
3631           parse_omp_structured_block (st, false);
3632           break;
3633
3634         case ST_OMP_WORKSHARE:
3635         case ST_OMP_PARALLEL_WORKSHARE:
3636           parse_omp_structured_block (st, true);
3637           break;
3638
3639         case ST_OMP_DO:
3640         case ST_OMP_PARALLEL_DO:
3641           st = parse_omp_do (st);
3642           if (st == ST_IMPLIED_ENDDO)
3643             return st;
3644           continue;
3645
3646         case ST_OMP_ATOMIC:
3647           parse_omp_atomic ();
3648           break;
3649
3650         default:
3651           return st;
3652         }
3653
3654       st = next_statement ();
3655     }
3656 }
3657
3658
3659 /* Fix the symbols for sibling functions.  These are incorrectly added to
3660    the child namespace as the parser didn't know about this procedure.  */
3661
3662 static void
3663 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3664 {
3665   gfc_namespace *ns;
3666   gfc_symtree *st;
3667   gfc_symbol *old_sym;
3668
3669   sym->attr.referenced = 1;
3670   for (ns = siblings; ns; ns = ns->sibling)
3671     {
3672       st = gfc_find_symtree (ns->sym_root, sym->name);
3673
3674       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3675         goto fixup_contained;
3676
3677       old_sym = st->n.sym;
3678       if (old_sym->ns == ns
3679             && !old_sym->attr.contained
3680
3681             /* By 14.6.1.3, host association should be excluded
3682                for the following.  */
3683             && !(old_sym->attr.external
3684                   || (old_sym->ts.type != BT_UNKNOWN
3685                         && !old_sym->attr.implicit_type)
3686                   || old_sym->attr.flavor == FL_PARAMETER
3687                   || old_sym->attr.in_common
3688                   || old_sym->attr.in_equivalence
3689                   || old_sym->attr.data
3690                   || old_sym->attr.dummy
3691                   || old_sym->attr.result
3692                   || old_sym->attr.dimension
3693                   || old_sym->attr.allocatable
3694                   || old_sym->attr.intrinsic
3695                   || old_sym->attr.generic
3696                   || old_sym->attr.flavor == FL_NAMELIST
3697                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3698         {
3699           /* Replace it with the symbol from the parent namespace.  */
3700           st->n.sym = sym;
3701           sym->refs++;
3702
3703           /* Free the old (local) symbol.  */
3704           old_sym->refs--;
3705           if (old_sym->refs == 0)
3706             gfc_free_symbol (old_sym);
3707         }
3708
3709 fixup_contained:
3710       /* Do the same for any contained procedures.  */
3711       gfc_fixup_sibling_symbols (sym, ns->contained);
3712     }
3713 }
3714
3715 static void
3716 parse_contained (int module)
3717 {
3718   gfc_namespace *ns, *parent_ns, *tmp;
3719   gfc_state_data s1, s2;
3720   gfc_statement st;
3721   gfc_symbol *sym;
3722   gfc_entry_list *el;
3723   int contains_statements = 0;
3724   int seen_error = 0;
3725
3726   push_state (&s1, COMP_CONTAINS, NULL);
3727   parent_ns = gfc_current_ns;
3728
3729   do
3730     {
3731       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3732
3733       gfc_current_ns->sibling = parent_ns->contained;
3734       parent_ns->contained = gfc_current_ns;
3735
3736  next:
3737       /* Process the next available statement.  We come here if we got an error
3738          and rejected the last statement.  */
3739       st = next_statement ();
3740
3741       switch (st)
3742         {
3743         case ST_NONE:
3744           unexpected_eof ();
3745
3746         case ST_FUNCTION:
3747         case ST_SUBROUTINE:
3748           contains_statements = 1;
3749           accept_statement (st);
3750
3751           push_state (&s2,
3752                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3753                       gfc_new_block);
3754
3755           /* For internal procedures, create/update the symbol in the
3756              parent namespace.  */
3757
3758           if (!module)
3759             {
3760               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3761                 gfc_error ("Contained procedure '%s' at %C is already "
3762                            "ambiguous", gfc_new_block->name);
3763               else
3764                 {
3765                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3766                                          &gfc_new_block->declared_at) ==
3767                       SUCCESS)
3768                     {
3769                       if (st == ST_FUNCTION)
3770                         gfc_add_function (&sym->attr, sym->name,
3771                                           &gfc_new_block->declared_at);
3772                       else
3773                         gfc_add_subroutine (&sym->attr, sym->name,
3774                                             &gfc_new_block->declared_at);
3775                     }
3776                 }
3777
3778               gfc_commit_symbols ();
3779             }
3780           else
3781             sym = gfc_new_block;
3782
3783           /* Mark this as a contained function, so it isn't replaced
3784              by other module functions.  */
3785           sym->attr.contained = 1;
3786           sym->attr.referenced = 1;
3787
3788           parse_progunit (ST_NONE);
3789
3790           /* Fix up any sibling functions that refer to this one.  */
3791           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3792           /* Or refer to any of its alternate entry points.  */
3793           for (el = gfc_current_ns->entries; el; el = el->next)
3794             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3795
3796           gfc_current_ns->code = s2.head;
3797           gfc_current_ns = parent_ns;
3798
3799           pop_state ();
3800           break;
3801
3802         /* These statements are associated with the end of the host unit.  */
3803         case ST_END_FUNCTION:
3804         case ST_END_MODULE:
3805         case ST_END_PROGRAM:
3806         case ST_END_SUBROUTINE:
3807           accept_statement (st);
3808           break;
3809
3810         default:
3811           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3812                      gfc_ascii_statement (st));
3813           reject_statement ();
3814           seen_error = 1;
3815           goto next;
3816           break;
3817         }
3818     }
3819   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3820          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3821
3822   /* The first namespace in the list is guaranteed to not have
3823      anything (worthwhile) in it.  */
3824   tmp = gfc_current_ns;
3825   gfc_current_ns = parent_ns;
3826   if (seen_error && tmp->refs > 1)
3827     gfc_free_namespace (tmp);
3828
3829   ns = gfc_current_ns->contained;
3830   gfc_current_ns->contained = ns->sibling;
3831   gfc_free_namespace (ns);
3832
3833   pop_state ();
3834   if (!contains_statements)
3835     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3836                     "FUNCTION or SUBROUTINE statement at %C");
3837 }
3838
3839
3840 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
3841
3842 static void
3843 parse_progunit (gfc_statement st)
3844 {
3845   gfc_state_data *p;
3846   int n;
3847
3848   st = parse_spec (st);
3849   switch (st)
3850     {
3851     case ST_NONE:
3852       unexpected_eof ();
3853
3854     case ST_CONTAINS:
3855       /* This is not allowed within BLOCK!  */
3856       if (gfc_current_state () != COMP_BLOCK)
3857         goto contains;
3858       break;
3859
3860     case_end:
3861       accept_statement (st);
3862       goto done;
3863
3864     default:
3865       break;
3866     }
3867
3868   if (gfc_current_state () == COMP_FUNCTION)
3869     gfc_check_function_type (gfc_current_ns);
3870
3871 loop:
3872   for (;;)
3873     {
3874       st = parse_executable (st);
3875
3876       switch (st)
3877         {
3878         case ST_NONE:
3879           unexpected_eof ();
3880
3881         case ST_CONTAINS:
3882           /* This is not allowed within BLOCK!  */
3883           if (gfc_current_state () != COMP_BLOCK)
3884             goto contains;
3885           break;
3886
3887         case_end:
3888           accept_statement (st);
3889           goto done;
3890
3891         default:
3892           break;
3893         }
3894
3895       unexpected_statement (st);
3896       reject_statement ();
3897       st = next_statement ();
3898     }
3899
3900 contains:
3901   n = 0;
3902
3903   for (p = gfc_state_stack; p; p = p->previous)
3904     if (p->state == COMP_CONTAINS)
3905       n++;
3906
3907   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3908     n--;
3909
3910   if (n > 0)
3911     {
3912       gfc_error ("CONTAINS statement at %C is already in a contained "
3913                  "program unit");
3914       st = next_statement ();
3915       goto loop;
3916     }
3917
3918   parse_contained (0);
3919
3920 done:
3921   gfc_current_ns->code = gfc_state_stack->head;
3922 }
3923
3924
3925 /* Come here to complain about a global symbol already in use as
3926    something else.  */
3927
3928 void
3929 gfc_global_used (gfc_gsymbol *sym, locus *where)
3930 {
3931   const char *name;
3932
3933   if (where == NULL)
3934     where = &gfc_current_locus;
3935
3936   switch(sym->type)
3937     {
3938     case GSYM_PROGRAM:
3939       name = "PROGRAM";
3940       break;
3941     case GSYM_FUNCTION:
3942       name = "FUNCTION";
3943       break;
3944     case GSYM_SUBROUTINE:
3945       name = "SUBROUTINE";
3946       break;
3947     case GSYM_COMMON:
3948       name = "COMMON";
3949       break;
3950     case GSYM_BLOCK_DATA:
3951       name = "BLOCK DATA";
3952       break;
3953     case GSYM_MODULE:
3954       name = "MODULE";
3955       break;
3956     default:
3957       gfc_internal_error ("gfc_global_used(): Bad type");
3958       name = NULL;
3959     }
3960
3961   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3962               sym->name, where, name, &sym->where);
3963 }
3964
3965
3966 /* Parse a block data program unit.  */
3967
3968 static void
3969 parse_block_data (void)
3970 {
3971   gfc_statement st;
3972   static locus blank_locus;
3973   static int blank_block=0;
3974   gfc_gsymbol *s;
3975
3976   gfc_current_ns->proc_name = gfc_new_block;
3977   gfc_current_ns->is_block_data = 1;
3978
3979   if (gfc_new_block == NULL)
3980     {
3981       if (blank_block)
3982        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3983                   "prior BLOCK DATA at %L", &blank_locus);
3984       else
3985        {
3986          blank_block = 1;
3987          blank_locus = gfc_current_locus;
3988        }
3989     }
3990   else
3991     {
3992       s = gfc_get_gsymbol (gfc_new_block->name);
3993       if (s->defined
3994           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3995        gfc_global_used(s, NULL);
3996       else
3997        {
3998          s->type = GSYM_BLOCK_DATA;
3999          s->where = gfc_current_locus;
4000          s->defined = 1;
4001        }
4002     }
4003
4004   st = parse_spec (ST_NONE);
4005
4006   while (st != ST_END_BLOCK_DATA)
4007     {
4008       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4009                  gfc_ascii_statement (st));
4010       reject_statement ();
4011       st = next_statement ();
4012     }
4013 }
4014
4015
4016 /* Parse a module subprogram.  */
4017
4018 static void
4019 parse_module (void)
4020 {
4021   gfc_statement st;
4022   gfc_gsymbol *s;
4023
4024   s = gfc_get_gsymbol (gfc_new_block->name);
4025   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4026     gfc_global_used(s, NULL);
4027   else
4028     {
4029       s->type = GSYM_MODULE;
4030       s->where = gfc_current_locus;
4031       s->defined = 1;
4032     }
4033
4034   st = parse_spec (ST_NONE);
4035
4036 loop:
4037   switch (st)
4038     {
4039     case ST_NONE:
4040       unexpected_eof ();
4041
4042     case ST_CONTAINS:
4043       parse_contained (1);
4044       break;
4045
4046     case ST_END_MODULE:
4047       accept_statement (st);
4048       break;
4049
4050     default:
4051       gfc_error ("Unexpected %s statement in MODULE at %C",
4052                  gfc_ascii_statement (st));
4053
4054       reject_statement ();
4055       st = next_statement ();
4056       goto loop;
4057     }
4058
4059   s->ns = gfc_current_ns;
4060 }
4061
4062
4063 /* Add a procedure name to the global symbol table.  */
4064
4065 static void
4066 add_global_procedure (int sub)
4067 {
4068   gfc_gsymbol *s;
4069
4070   s = gfc_get_gsymbol(gfc_new_block->name);
4071
4072   if (s->defined
4073       || (s->type != GSYM_UNKNOWN
4074           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4075     gfc_global_used(s, NULL);
4076   else
4077     {
4078       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4079       s->where = gfc_current_locus;
4080       s->defined = 1;
4081       s->ns = gfc_current_ns;
4082     }
4083 }
4084
4085
4086 /* Add a program to the global symbol table.  */
4087
4088 static void
4089 add_global_program (void)
4090 {
4091   gfc_gsymbol *s;
4092
4093   if (gfc_new_block == NULL)
4094     return;
4095   s = gfc_get_gsymbol (gfc_new_block->name);
4096
4097   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4098     gfc_global_used(s, NULL);
4099   else
4100     {
4101       s->type = GSYM_PROGRAM;
4102       s->where = gfc_current_locus;
4103       s->defined = 1;
4104       s->ns = gfc_current_ns;
4105     }
4106 }
4107
4108
4109 /* Resolve all the program units when whole file scope option
4110    is active. */
4111 static void
4112 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4113 {
4114   gfc_free_dt_list ();
4115   gfc_current_ns = gfc_global_ns_list;
4116   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4117     {
4118       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4119       gfc_resolve (gfc_current_ns);
4120       gfc_current_ns->derived_types = gfc_derived_types;
4121       gfc_derived_types = NULL;
4122     }
4123 }
4124
4125
4126 static void
4127 clean_up_modules (gfc_gsymbol *gsym)
4128 {
4129   if (gsym == NULL)
4130     return;
4131
4132   clean_up_modules (gsym->left);
4133   clean_up_modules (gsym->right);
4134
4135   if (gsym->type != GSYM_MODULE || !gsym->ns)
4136     return;
4137
4138   gfc_current_ns = gsym->ns;
4139   gfc_derived_types = gfc_current_ns->derived_types;
4140   gfc_done_2 ();
4141   gsym->ns = NULL;
4142   return;
4143 }
4144
4145
4146 /* Translate all the program units when whole file scope option
4147    is active. This could be in a different order to resolution if
4148    there are forward references in the file.  */
4149 static void
4150 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4151 {
4152   int errors;
4153
4154   gfc_current_ns = gfc_global_ns_list;
4155   gfc_get_errors (NULL, &errors);
4156
4157   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4158     {
4159       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4160       gfc_derived_types = gfc_current_ns->derived_types;
4161       gfc_generate_code (gfc_current_ns);
4162       gfc_current_ns->translated = 1;
4163     }
4164
4165   /* Clean up all the namespaces after translation.  */
4166   gfc_current_ns = gfc_global_ns_list;
4167   for (;gfc_current_ns;)
4168     {
4169       gfc_namespace *ns = gfc_current_ns->sibling;
4170       gfc_derived_types = gfc_current_ns->derived_types;
4171       gfc_done_2 ();
4172       gfc_current_ns = ns;
4173     }
4174
4175   clean_up_modules (gfc_gsym_root);
4176 }
4177
4178
4179 /* Top level parser.  */
4180
4181 gfc_try
4182 gfc_parse_file (void)
4183 {
4184   int seen_program, errors_before, errors;
4185   gfc_state_data top, s;
4186   gfc_statement st;
4187   locus prog_locus;
4188   gfc_namespace *next;
4189
4190   gfc_start_source_files ();
4191
4192   top.state = COMP_NONE;
4193   top.sym = NULL;
4194   top.previous = NULL;
4195   top.head = top.tail = NULL;
4196   top.do_variable = NULL;
4197
4198   gfc_state_stack = &top;
4199
4200   gfc_clear_new_st ();
4201
4202   gfc_statement_label = NULL;
4203
4204   if (setjmp (eof_buf))
4205     return FAILURE;     /* Come here on unexpected EOF */
4206
4207   /* Prepare the global namespace that will contain the
4208      program units.  */
4209   gfc_global_ns_list = next = NULL;
4210
4211   seen_program = 0;
4212
4213   /* Exit early for empty files.  */
4214   if (gfc_at_eof ())
4215     goto done;
4216
4217 loop:
4218   gfc_init_2 ();
4219   st = next_statement ();
4220   switch (st)
4221     {
4222     case ST_NONE:
4223       gfc_done_2 ();
4224       goto done;
4225
4226     case ST_PROGRAM:
4227       if (seen_program)
4228         goto duplicate_main;
4229       seen_program = 1;
4230       prog_locus = gfc_current_locus;
4231
4232       push_state (&s, COMP_PROGRAM, gfc_new_block);
4233       main_program_symbol(gfc_current_ns, gfc_new_block->name);
4234       accept_statement (st);
4235       add_global_program ();
4236       parse_progunit (ST_NONE);
4237       if (gfc_option.flag_whole_file)
4238         goto prog_units;
4239       break;
4240
4241     case ST_SUBROUTINE:
4242       add_global_procedure (1);
4243       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4244       accept_statement (st);
4245       parse_progunit (ST_NONE);
4246       if (gfc_option.flag_whole_file)
4247         goto prog_units;
4248       break;
4249
4250     case ST_FUNCTION:
4251       add_global_procedure (0);
4252       push_state (&s, COMP_FUNCTION, gfc_new_block);
4253       accept_statement (st);
4254       parse_progunit (ST_NONE);
4255       if (gfc_option.flag_whole_file)
4256         goto prog_units;
4257       break;
4258
4259     case ST_BLOCK_DATA:
4260       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4261       accept_statement (st);
4262       parse_block_data ();
4263       break;
4264
4265     case ST_MODULE:
4266       push_state (&s, COMP_MODULE, gfc_new_block);
4267       accept_statement (st);
4268
4269       gfc_get_errors (NULL, &errors_before);
4270       parse_module ();
4271       break;
4272
4273     /* Anything else starts a nameless main program block.  */
4274     default:
4275       if (seen_program)
4276         goto duplicate_main;
4277       seen_program = 1;
4278       prog_locus = gfc_current_locus;
4279
4280       push_state (&s, COMP_PROGRAM, gfc_new_block);
4281       main_program_symbol (gfc_current_ns, "MAIN__");
4282       parse_progunit (st);
4283       if (gfc_option.flag_whole_file)
4284         goto prog_units;
4285       break;
4286     }
4287
4288   /* Handle the non-program units.  */
4289   gfc_current_ns->code = s.head;
4290
4291   gfc_resolve (gfc_current_ns);
4292
4293   /* Dump the parse tree if requested.  */
4294   if (gfc_option.dump_parse_tree)
4295     gfc_dump_parse_tree (gfc_current_ns, stdout);
4296
4297   gfc_get_errors (NULL, &errors);
4298   if (s.state == COMP_MODULE)
4299     {
4300       gfc_dump_module (s.sym->name, errors_before == errors);
4301       if (errors == 0)
4302         gfc_generate_module_code (gfc_current_ns);
4303       pop_state ();
4304       if (!gfc_option.flag_whole_file)
4305         gfc_done_2 ();
4306       else
4307         {
4308           gfc_current_ns->derived_types = gfc_derived_types;
4309           gfc_derived_types = NULL;
4310           gfc_current_ns = NULL;
4311         }
4312     }
4313   else
4314     {
4315       if (errors == 0)
4316         gfc_generate_code (gfc_current_ns);
4317       pop_state ();
4318       gfc_done_2 ();
4319     }
4320
4321   goto loop;
4322
4323 prog_units:
4324   /* The main program and non-contained procedures are put
4325      in the global namespace list, so that they can be processed
4326      later and all their interfaces resolved.  */
4327   gfc_current_ns->code = s.head;
4328   if (next)
4329     next->sibling = gfc_current_ns;
4330   else
4331     gfc_global_ns_list = gfc_current_ns;
4332
4333   next = gfc_current_ns;
4334
4335   pop_state ();
4336   goto loop;
4337
4338   done:
4339
4340   if (!gfc_option.flag_whole_file)
4341     goto termination;
4342
4343   /* Do the resolution.  */
4344   resolve_all_program_units (gfc_global_ns_list);
4345
4346   /* Do the parse tree dump.  */ 
4347   gfc_current_ns
4348         = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
4349
4350   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4351     {
4352       gfc_dump_parse_tree (gfc_current_ns, stdout);
4353       fputs ("------------------------------------------\n\n", stdout);
4354     }
4355
4356   /* Do the translation.  */
4357   translate_all_program_units (gfc_global_ns_list);
4358
4359 termination:
4360
4361   gfc_end_source_files ();