OSDN Git Service

PR fortran/15586
[pf3gnuchains/gcc-fork.git] / gcc / fortran / parse.c
1 /* Main parser.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, 
3    Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23
24 #include "config.h"
25 #include "system.h"
26 #include <setjmp.h>
27 #include "gfortran.h"
28 #include "match.h"
29 #include "parse.h"
30
31 /* Current statement label.  Zero means no statement label.  Because
32    new_st can get wiped during statement matching, we have to keep it
33    separate.  */
34
35 gfc_st_label *gfc_statement_label;
36
37 static locus label_locus;
38 static jmp_buf eof_buf;
39
40 gfc_state_data *gfc_state_stack;
41
42 /* TODO: Re-order functions to kill these forward decls.  */
43 static void check_statement_label (gfc_statement);
44 static void undo_new_statement (void);
45 static void reject_statement (void);
46
47 /* 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 static gfc_statement
90 decode_statement (void)
91 {
92   gfc_statement st;
93   locus old_locus;
94   match m;
95   int c;
96
97 #ifdef GFC_DEBUG
98   gfc_symbol_state ();
99 #endif
100
101   gfc_clear_error ();   /* Clear any pending errors.  */
102   gfc_clear_warning (); /* Clear any pending warnings.  */
103
104   if (gfc_match_eos () == MATCH_YES)
105     return ST_NONE;
106
107   old_locus = gfc_current_locus;
108
109   /* Try matching a data declaration or function declaration. The
110       input "REALFUNCTIONA(N)" can mean several things in different
111       contexts, so it (and its relatives) get special treatment.  */
112
113   if (gfc_current_state () == COMP_NONE
114       || gfc_current_state () == COMP_INTERFACE
115       || gfc_current_state () == COMP_CONTAINS)
116     {
117       m = gfc_match_function_decl ();
118       if (m == MATCH_YES)
119         return ST_FUNCTION;
120       else if (m == MATCH_ERROR)
121         reject_statement ();
122
123       gfc_undo_symbols ();
124       gfc_current_locus = old_locus;
125     }
126
127   /* Match statements whose error messages are meant to be overwritten
128      by something better.  */
129
130   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
131   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
132   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
133
134   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
135
136   /* Try to match a subroutine statement, which has the same optional
137      prefixes that functions can have.  */
138
139   if (gfc_match_subroutine () == MATCH_YES)
140     return ST_SUBROUTINE;
141   gfc_undo_symbols ();
142   gfc_current_locus = old_locus;
143
144   /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
145      might begin with a block label.  The match functions for these
146      statements are unusual in that their keyword is not seen before
147      the matcher is called.  */
148
149   if (gfc_match_if (&st) == MATCH_YES)
150     return st;
151   gfc_undo_symbols ();
152   gfc_current_locus = old_locus;
153
154   if (gfc_match_where (&st) == MATCH_YES)
155     return st;
156   gfc_undo_symbols ();
157   gfc_current_locus = old_locus;
158
159   if (gfc_match_forall (&st) == MATCH_YES)
160     return st;
161   gfc_undo_symbols ();
162   gfc_current_locus = old_locus;
163
164   match (NULL, gfc_match_do, ST_DO);
165   match (NULL, gfc_match_select, ST_SELECT_CASE);
166
167   /* General statement matching: Instead of testing every possible
168      statement, we eliminate most possibilities by peeking at the
169      first character.  */
170
171   c = gfc_peek_char ();
172
173   switch (c)
174     {
175     case 'a':
176       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
177       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
178       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
179       break;
180
181     case 'b':
182       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
183       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
184       break;
185
186     case 'c':
187       match ("call", gfc_match_call, ST_CALL);
188       match ("close", gfc_match_close, ST_CLOSE);
189       match ("continue", gfc_match_continue, ST_CONTINUE);
190       match ("cycle", gfc_match_cycle, ST_CYCLE);
191       match ("case", gfc_match_case, ST_CASE);
192       match ("common", gfc_match_common, ST_COMMON);
193       match ("contains", gfc_match_eos, ST_CONTAINS);
194       break;
195
196     case 'd':
197       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
198       match ("data", gfc_match_data, ST_DATA);
199       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
200       break;
201
202     case 'e':
203       match ("end file", gfc_match_endfile, ST_END_FILE);
204       match ("exit", gfc_match_exit, ST_EXIT);
205       match ("else", gfc_match_else, ST_ELSE);
206       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
207       match ("else if", gfc_match_elseif, ST_ELSEIF);
208
209       if (gfc_match_end (&st) == MATCH_YES)
210         return st;
211
212       match ("entry% ", gfc_match_entry, ST_ENTRY);
213       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
214       match ("external", gfc_match_external, ST_ATTR_DECL);
215       break;
216
217     case 'f':
218       match ("flush", gfc_match_flush, ST_FLUSH);
219       match ("format", gfc_match_format, ST_FORMAT);
220       break;
221
222     case 'g':
223       match ("go to", gfc_match_goto, ST_GOTO);
224       break;
225
226     case 'i':
227       match ("inquire", gfc_match_inquire, ST_INQUIRE);
228       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
229       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
230       match ("interface", gfc_match_interface, ST_INTERFACE);
231       match ("intent", gfc_match_intent, ST_ATTR_DECL);
232       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
233       break;
234
235     case 'm':
236       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
237       match ("module", gfc_match_module, ST_MODULE);
238       break;
239
240     case 'n':
241       match ("nullify", gfc_match_nullify, ST_NULLIFY);
242       match ("namelist", gfc_match_namelist, ST_NAMELIST);
243       break;
244
245     case 'o':
246       match ("open", gfc_match_open, ST_OPEN);
247       match ("optional", gfc_match_optional, ST_ATTR_DECL);
248       break;
249
250     case 'p':
251       match ("print", gfc_match_print, ST_WRITE);
252       match ("parameter", gfc_match_parameter, ST_PARAMETER);
253       match ("pause", gfc_match_pause, ST_PAUSE);
254       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
255       if (gfc_match_private (&st) == MATCH_YES)
256         return st;
257       match ("program", gfc_match_program, ST_PROGRAM);
258       if (gfc_match_public (&st) == MATCH_YES)
259         return st;
260       break;
261
262     case 'r':
263       match ("read", gfc_match_read, ST_READ);
264       match ("return", gfc_match_return, ST_RETURN);
265       match ("rewind", gfc_match_rewind, ST_REWIND);
266       break;
267
268     case 's':
269       match ("sequence", gfc_match_eos, ST_SEQUENCE);
270       match ("stop", gfc_match_stop, ST_STOP);
271       match ("save", gfc_match_save, ST_ATTR_DECL);
272       break;
273
274     case 't':
275       match ("target", gfc_match_target, ST_ATTR_DECL);
276       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
277       break;
278
279     case 'u':
280       match ("use% ", gfc_match_use, ST_USE);
281       break;
282
283     case 'w':
284       match ("write", gfc_match_write, ST_WRITE);
285       break;
286     }
287
288   /* All else has failed, so give up.  See if any of the matchers has
289      stored an error message of some sort.  */
290
291   if (gfc_error_check () == 0)
292     gfc_error_now ("Unclassifiable statement at %C");
293
294   reject_statement ();
295
296   gfc_error_recovery ();
297
298   return ST_NONE;
299 }
300
301 #undef match
302
303
304 /* Get the next statement in free form source.  */
305
306 static gfc_statement
307 next_free (void)
308 {
309   match m;
310   int c, d;
311
312   gfc_gobble_whitespace ();
313
314   c = gfc_peek_char ();
315
316   if (ISDIGIT (c))
317     {
318       /* Found a statement label?  */
319       m = gfc_match_st_label (&gfc_statement_label, 0);
320
321       d = gfc_peek_char ();
322       if (m != MATCH_YES || !gfc_is_whitespace (d))
323         {
324           do
325             {
326               /* Skip the bad statement label.  */
327               gfc_warning_now ("Ignoring bad statement label at %C");
328               c = gfc_next_char ();
329             }
330           while (ISDIGIT (c));
331         }
332       else
333         {
334           label_locus = gfc_current_locus;
335
336           if (gfc_statement_label->value == 0)
337             {
338               gfc_warning_now ("Ignoring statement label of zero at %C");
339               gfc_free_st_label (gfc_statement_label);
340               gfc_statement_label = NULL;
341             }
342
343           gfc_gobble_whitespace ();
344
345           if (gfc_match_eos () == MATCH_YES)
346             {
347               gfc_warning_now
348                 ("Ignoring statement label in empty statement at %C");
349               gfc_free_st_label (gfc_statement_label);
350               gfc_statement_label = NULL;
351               return ST_NONE;
352             }
353         }
354     }
355
356   return decode_statement ();
357 }
358
359
360 /* Get the next statement in fixed-form source.  */
361
362 static gfc_statement
363 next_fixed (void)
364 {
365   int label, digit_flag, i;
366   locus loc;
367   char c;
368
369   if (!gfc_at_bol ())
370     return decode_statement ();
371
372   /* Skip past the current label field, parsing a statement label if
373      one is there.  This is a weird number parser, since the number is
374      contained within five columns and can have any kind of embedded
375      spaces.  We also check for characters that make the rest of the
376      line a comment.  */
377
378   label = 0;
379   digit_flag = 0;
380
381   for (i = 0; i < 5; i++)
382     {
383       c = gfc_next_char_literal (0);
384
385       switch (c)
386         {
387         case ' ':
388           break;
389
390         case '0':
391         case '1':
392         case '2':
393         case '3':
394         case '4':
395         case '5':
396         case '6':
397         case '7':
398         case '8':
399         case '9':
400           label = label * 10 + c - '0';
401           label_locus = gfc_current_locus;
402           digit_flag = 1;
403           break;
404
405           /* Comments have already been skipped by the time we get
406              here so don't bother checking for them.  */
407
408         default:
409           gfc_buffer_error (0);
410           gfc_error ("Non-numeric character in statement label at %C");
411           return ST_NONE;
412         }
413     }
414
415   if (digit_flag)
416     {
417       if (label == 0)
418         gfc_warning_now ("Zero is not a valid statement label at %C");
419       else
420         {
421           /* We've found a valid statement label.  */
422           gfc_statement_label = gfc_get_st_label (label);
423         }
424     }
425
426   /* Since this line starts a statement, it cannot be a continuation
427      of a previous statement.  If we see something here besides a
428      space or zero, it must be a bad continuation line.  */
429
430   c = gfc_next_char_literal (0);
431   if (c == '\n')
432     goto blank_line;
433
434   if (c != ' ' && c!= '0')
435     {
436       gfc_buffer_error (0);
437       gfc_error ("Bad continuation line at %C");
438       return ST_NONE;
439     }
440
441   /* Now that we've taken care of the statement label columns, we have
442      to make sure that the first nonblank character is not a '!'.  If
443      it is, the rest of the line is a comment.  */
444
445   do
446     {
447       loc = gfc_current_locus;
448       c = gfc_next_char_literal (0);
449     }
450   while (gfc_is_whitespace (c));
451
452   if (c == '!')
453     goto blank_line;
454   gfc_current_locus = loc;
455
456   if (gfc_match_eos () == MATCH_YES)
457     goto blank_line;
458
459   /* At this point, we've got a nonblank statement to parse.  */
460   return decode_statement ();
461
462 blank_line:
463   if (digit_flag)
464     gfc_warning ("Statement label in blank line will be " "ignored at %C");
465   gfc_advance_line ();
466   return ST_NONE;
467 }
468
469
470 /* Return the next non-ST_NONE statement to the caller.  We also worry
471    about including files and the ends of include files at this stage.  */
472
473 static gfc_statement
474 next_statement (void)
475 {
476   gfc_statement st;
477
478   gfc_new_block = NULL;
479
480   for (;;)
481     {
482       gfc_statement_label = NULL;
483       gfc_buffer_error (1);
484
485       if (gfc_at_eol ())
486         {
487           if (gfc_option.warn_line_truncation
488               && gfc_current_locus.lb->truncated)
489             gfc_warning_now ("Line truncated at %C");
490
491           gfc_advance_line ();
492         }
493
494       gfc_skip_comments ();
495
496       if (gfc_at_end ())
497         {
498           st = ST_NONE;
499           break;
500         }
501
502       st =
503         (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
504
505       if (st != ST_NONE)
506         break;
507     }
508
509   gfc_buffer_error (0);
510
511   if (st != ST_NONE)
512     check_statement_label (st);
513
514   return st;
515 }
516
517
518 /****************************** Parser ***********************************/
519
520 /* The parser subroutines are of type 'try' that fail if the file ends
521    unexpectedly.  */
522
523 /* Macros that expand to case-labels for various classes of
524    statements.  Start with executable statements that directly do
525    things.  */
526
527 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
528   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
529   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
530   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
531   case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
532   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
533   case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
534   case ST_LABEL_ASSIGNMENT: case ST_FLUSH
535
536 /* Statements that mark other executable statements.  */
537
538 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
539   case ST_WHERE_BLOCK: case ST_SELECT_CASE
540
541 /* Declaration statements */
542
543 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
544   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
545   case ST_TYPE: case ST_INTERFACE
546
547 /* Block end statements.  Errors associated with interchanging these
548    are detected in gfc_match_end().  */
549
550 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
551                  case ST_END_PROGRAM: case ST_END_SUBROUTINE
552
553
554 /* Push a new state onto the stack.  */
555
556 static void
557 push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
558 {
559
560   p->state = new_state;
561   p->previous = gfc_state_stack;
562   p->sym = sym;
563   p->head = p->tail = NULL;
564   p->do_variable = NULL;
565
566   gfc_state_stack = p;
567 }
568
569
570 /* Pop the current state.  */
571
572 static void
573 pop_state (void)
574 {
575
576   gfc_state_stack = gfc_state_stack->previous;
577 }
578
579
580 /* Try to find the given state in the state stack.  */
581
582 try
583 gfc_find_state (gfc_compile_state state)
584 {
585   gfc_state_data *p;
586
587   for (p = gfc_state_stack; p; p = p->previous)
588     if (p->state == state)
589       break;
590
591   return (p == NULL) ? FAILURE : SUCCESS;
592 }
593
594
595 /* Starts a new level in the statement list.  */
596
597 static gfc_code *
598 new_level (gfc_code * q)
599 {
600   gfc_code *p;
601
602   p = q->block = gfc_get_code ();
603
604   gfc_state_stack->head = gfc_state_stack->tail = p;
605
606   return p;
607 }
608
609
610 /* Add the current new_st code structure and adds it to the current
611    program unit.  As a side-effect, it zeroes the new_st.  */
612
613 static gfc_code *
614 add_statement (void)
615 {
616   gfc_code *p;
617
618   p = gfc_get_code ();
619   *p = new_st;
620
621   p->loc = gfc_current_locus;
622
623   if (gfc_state_stack->head == NULL)
624     gfc_state_stack->head = p;
625   else
626     gfc_state_stack->tail->next = p;
627
628   while (p->next != NULL)
629     p = p->next;
630
631   gfc_state_stack->tail = p;
632
633   gfc_clear_new_st ();
634
635   return p;
636 }
637
638
639 /* Frees everything associated with the current statement.  */
640
641 static void
642 undo_new_statement (void)
643 {
644   gfc_free_statements (new_st.block);
645   gfc_free_statements (new_st.next);
646   gfc_free_statement (&new_st);
647   gfc_clear_new_st ();
648 }
649
650
651 /* If the current statement has a statement label, make sure that it
652    is allowed to, or should have one.  */
653
654 static void
655 check_statement_label (gfc_statement st)
656 {
657   gfc_sl_type type;
658
659   if (gfc_statement_label == NULL)
660     {
661       if (st == ST_FORMAT)
662         gfc_error ("FORMAT statement at %L does not have a statement label",
663                    &new_st.loc);
664       return;
665     }
666
667   switch (st)
668     {
669     case ST_END_PROGRAM:
670     case ST_END_FUNCTION:
671     case ST_END_SUBROUTINE:
672     case ST_ENDDO:
673     case ST_ENDIF:
674     case ST_END_SELECT:
675     case_executable:
676     case_exec_markers:
677       type = ST_LABEL_TARGET;
678       break;
679
680     case ST_FORMAT:
681       type = ST_LABEL_FORMAT;
682       break;
683
684       /* Statement labels are not restricted from appearing on a
685          particular line.  However, there are plenty of situations
686          where the resulting label can't be referenced.  */
687
688     default:
689       type = ST_LABEL_BAD_TARGET;
690       break;
691     }
692
693   gfc_define_st_label (gfc_statement_label, type, &label_locus);
694
695   new_st.here = gfc_statement_label;
696 }
697
698
699 /* Figures out what the enclosing program unit is.  This will be a
700    function, subroutine, program, block data or module.  */
701
702 gfc_state_data *
703 gfc_enclosing_unit (gfc_compile_state * result)
704 {
705   gfc_state_data *p;
706
707   for (p = gfc_state_stack; p; p = p->previous)
708     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
709         || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
710         || p->state == COMP_PROGRAM)
711       {
712
713         if (result != NULL)
714           *result = p->state;
715         return p;
716       }
717
718   if (result != NULL)
719     *result = COMP_PROGRAM;
720   return NULL;
721 }
722
723
724 /* Translate a statement enum to a string.  */
725
726 const char *
727 gfc_ascii_statement (gfc_statement st)
728 {
729   const char *p;
730
731   switch (st)
732     {
733     case ST_ARITHMETIC_IF:
734       p = _("arithmetic IF");
735       break;
736     case ST_ALLOCATE:
737       p = "ALLOCATE";
738       break;
739     case ST_ATTR_DECL:
740       p = _("attribute declaration");
741       break;
742     case ST_BACKSPACE:
743       p = "BACKSPACE";
744       break;
745     case ST_BLOCK_DATA:
746       p = "BLOCK DATA";
747       break;
748     case ST_CALL:
749       p = "CALL";
750       break;
751     case ST_CASE:
752       p = "CASE";
753       break;
754     case ST_CLOSE:
755       p = "CLOSE";
756       break;
757     case ST_COMMON:
758       p = "COMMON";
759       break;
760     case ST_CONTINUE:
761       p = "CONTINUE";
762       break;
763     case ST_CONTAINS:
764       p = "CONTAINS";
765       break;
766     case ST_CYCLE:
767       p = "CYCLE";
768       break;
769     case ST_DATA_DECL:
770       p = _("data declaration");
771       break;
772     case ST_DATA:
773       p = "DATA";
774       break;
775     case ST_DEALLOCATE:
776       p = "DEALLOCATE";
777       break;
778     case ST_DERIVED_DECL:
779       p = _("derived type declaration");
780       break;
781     case ST_DO:
782       p = "DO";
783       break;
784     case ST_ELSE:
785       p = "ELSE";
786       break;
787     case ST_ELSEIF:
788       p = "ELSE IF";
789       break;
790     case ST_ELSEWHERE:
791       p = "ELSEWHERE";
792       break;
793     case ST_END_BLOCK_DATA:
794       p = "END BLOCK DATA";
795       break;
796     case ST_ENDDO:
797       p = "END DO";
798       break;
799     case ST_END_FILE:
800       p = "END FILE";
801       break;
802     case ST_END_FORALL:
803       p = "END FORALL";
804       break;
805     case ST_END_FUNCTION:
806       p = "END FUNCTION";
807       break;
808     case ST_ENDIF:
809       p = "END IF";
810       break;
811     case ST_END_INTERFACE:
812       p = "END INTERFACE";
813       break;
814     case ST_END_MODULE:
815       p = "END MODULE";
816       break;
817     case ST_END_PROGRAM:
818       p = "END PROGRAM";
819       break;
820     case ST_END_SELECT:
821       p = "END SELECT";
822       break;
823     case ST_END_SUBROUTINE:
824       p = "END SUBROUTINE";
825       break;
826     case ST_END_WHERE:
827       p = "END WHERE";
828       break;
829     case ST_END_TYPE:
830       p = "END TYPE";
831       break;
832     case ST_ENTRY:
833       p = "ENTRY";
834       break;
835     case ST_EQUIVALENCE:
836       p = "EQUIVALENCE";
837       break;
838     case ST_EXIT:
839       p = "EXIT";
840       break;
841     case ST_FLUSH:
842       p = "FLUSH";
843       break;
844     case ST_FORALL_BLOCK:       /* Fall through */
845     case ST_FORALL:
846       p = "FORALL";
847       break;
848     case ST_FORMAT:
849       p = "FORMAT";
850       break;
851     case ST_FUNCTION:
852       p = "FUNCTION";
853       break;
854     case ST_GOTO:
855       p = "GOTO";
856       break;
857     case ST_IF_BLOCK:
858       p = _("block IF");
859       break;
860     case ST_IMPLICIT:
861       p = "IMPLICIT";
862       break;
863     case ST_IMPLICIT_NONE:
864       p = "IMPLICIT NONE";
865       break;
866     case ST_IMPLIED_ENDDO:
867       p = _("implied END DO");
868       break;
869     case ST_INQUIRE:
870       p = "INQUIRE";
871       break;
872     case ST_INTERFACE:
873       p = "INTERFACE";
874       break;
875     case ST_PARAMETER:
876       p = "PARAMETER";
877       break;
878     case ST_PRIVATE:
879       p = "PRIVATE";
880       break;
881     case ST_PUBLIC:
882       p = "PUBLIC";
883       break;
884     case ST_MODULE:
885       p = "MODULE";
886       break;
887     case ST_PAUSE:
888       p = "PAUSE";
889       break;
890     case ST_MODULE_PROC:
891       p = "MODULE PROCEDURE";
892       break;
893     case ST_NAMELIST:
894       p = "NAMELIST";
895       break;
896     case ST_NULLIFY:
897       p = "NULLIFY";
898       break;
899     case ST_OPEN:
900       p = "OPEN";
901       break;
902     case ST_PROGRAM:
903       p = "PROGRAM";
904       break;
905     case ST_READ:
906       p = "READ";
907       break;
908     case ST_RETURN:
909       p = "RETURN";
910       break;
911     case ST_REWIND:
912       p = "REWIND";
913       break;
914     case ST_STOP:
915       p = "STOP";
916       break;
917     case ST_SUBROUTINE:
918       p = "SUBROUTINE";
919       break;
920     case ST_TYPE:
921       p = "TYPE";
922       break;
923     case ST_USE:
924       p = "USE";
925       break;
926     case ST_WHERE_BLOCK:        /* Fall through */
927     case ST_WHERE:
928       p = "WHERE";
929       break;
930     case ST_WRITE:
931       p = "WRITE";
932       break;
933     case ST_ASSIGNMENT:
934       p = _("assignment");
935       break;
936     case ST_POINTER_ASSIGNMENT:
937       p = _("pointer assignment");
938       break;
939     case ST_SELECT_CASE:
940       p = "SELECT CASE";
941       break;
942     case ST_SEQUENCE:
943       p = "SEQUENCE";
944       break;
945     case ST_SIMPLE_IF:
946       p = _("simple IF");
947       break;
948     case ST_STATEMENT_FUNCTION:
949       p = "STATEMENT FUNCTION";
950       break;
951     case ST_LABEL_ASSIGNMENT:
952       p = "LABEL ASSIGNMENT";
953       break;
954     default:
955       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
956     }
957
958   return p;
959 }
960
961
962 /* Do whatever is necessary to accept the last statement.  */
963
964 static void
965 accept_statement (gfc_statement st)
966 {
967
968   switch (st)
969     {
970     case ST_USE:
971       gfc_use_module ();
972       break;
973
974     case ST_IMPLICIT_NONE:
975       gfc_set_implicit_none ();
976       break;
977
978     case ST_IMPLICIT:
979       break;
980
981     case ST_FUNCTION:
982     case ST_SUBROUTINE:
983     case ST_MODULE:
984       gfc_current_ns->proc_name = gfc_new_block;
985       break;
986
987       /* If the statement is the end of a block, lay down a special code
988          that allows a branch to the end of the block from within the
989          construct.  */
990
991     case ST_ENDIF:
992     case ST_END_SELECT:
993       if (gfc_statement_label != NULL)
994         {
995           new_st.op = EXEC_NOP;
996           add_statement ();
997         }
998
999       break;
1000
1001       /* The end-of-program unit statements do not get the special
1002          marker and require a statement of some sort if they are a
1003          branch target.  */
1004
1005     case ST_END_PROGRAM:
1006     case ST_END_FUNCTION:
1007     case ST_END_SUBROUTINE:
1008       if (gfc_statement_label != NULL)
1009         {
1010           new_st.op = EXEC_RETURN;
1011           add_statement ();
1012         }
1013
1014       break;
1015
1016     case ST_ENTRY:
1017     case_executable:
1018     case_exec_markers:
1019       add_statement ();
1020       break;
1021
1022     default:
1023       break;
1024     }
1025
1026   gfc_commit_symbols ();
1027   gfc_warning_check ();
1028   gfc_clear_new_st ();
1029 }
1030
1031
1032 /* Undo anything tentative that has been built for the current
1033    statement.  */
1034
1035 static void
1036 reject_statement (void)
1037 {
1038
1039   gfc_undo_symbols ();
1040   gfc_clear_warning ();
1041   undo_new_statement ();
1042 }
1043
1044
1045 /* Generic complaint about an out of order statement.  We also do
1046    whatever is necessary to clean up.  */
1047
1048 static void
1049 unexpected_statement (gfc_statement st)
1050 {
1051
1052   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1053
1054   reject_statement ();
1055 }
1056
1057
1058 /* Given the next statement seen by the matcher, make sure that it is
1059    in proper order with the last.  This subroutine is initialized by
1060    calling it with an argument of ST_NONE.  If there is a problem, we
1061    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1062
1063    Individual parsers need to verify that the statements seen are
1064    valid before calling here, ie ENTRY statements are not allowed in
1065    INTERFACE blocks.  The following diagram is taken from the standard:
1066
1067             +---------------------------------------+
1068             | program  subroutine  function  module |
1069             +---------------------------------------+
1070             |                 use                   |
1071             |---------------------------------------+
1072             |        |        implicit none         |
1073             |        +-----------+------------------+
1074             |        | parameter |  implicit        |
1075             |        +-----------+------------------+
1076             | format |           |  derived type    |
1077             | entry  | parameter |  interface       |
1078             |        |   data    |  specification   |
1079             |        |           |  statement func  |
1080             |        +-----------+------------------+
1081             |        |   data    |    executable    |
1082             +--------+-----------+------------------+
1083             |                contains               |
1084             +---------------------------------------+
1085             |      internal module/subprogram       |
1086             +---------------------------------------+
1087             |                   end                 |
1088             +---------------------------------------+
1089
1090 */
1091
1092 typedef struct
1093 {
1094   enum
1095   { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
1096     ORDER_SPEC, ORDER_EXEC
1097   }
1098   state;
1099   gfc_statement last_statement;
1100   locus where;
1101 }
1102 st_state;
1103
1104 static try
1105 verify_st_order (st_state * p, gfc_statement st)
1106 {
1107
1108   switch (st)
1109     {
1110     case ST_NONE:
1111       p->state = ORDER_START;
1112       break;
1113
1114     case ST_USE:
1115       if (p->state > ORDER_USE)
1116         goto order;
1117       p->state = ORDER_USE;
1118       break;
1119
1120     case ST_IMPLICIT_NONE:
1121       if (p->state > ORDER_IMPLICIT_NONE)
1122         goto order;
1123
1124    /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1125       statement disqualifies a USE but not an IMPLICIT NONE.
1126       Duplicate IMPLICIT NONEs are caught when the implicit types
1127       are set.  */
1128
1129       p->state = ORDER_IMPLICIT_NONE;
1130       break;
1131
1132     case ST_IMPLICIT:
1133       if (p->state > ORDER_IMPLICIT)
1134         goto order;
1135       p->state = ORDER_IMPLICIT;
1136       break;
1137
1138     case ST_FORMAT:
1139     case ST_ENTRY:
1140       if (p->state < ORDER_IMPLICIT_NONE)
1141         p->state = ORDER_IMPLICIT_NONE;
1142       break;
1143
1144     case ST_PARAMETER:
1145       if (p->state >= ORDER_EXEC)
1146         goto order;
1147       if (p->state < ORDER_IMPLICIT)
1148         p->state = ORDER_IMPLICIT;
1149       break;
1150
1151     case ST_DATA:
1152       if (p->state < ORDER_SPEC)
1153         p->state = ORDER_SPEC;
1154       break;
1155
1156     case ST_PUBLIC:
1157     case ST_PRIVATE:
1158     case ST_DERIVED_DECL:
1159     case_decl:
1160       if (p->state >= ORDER_EXEC)
1161         goto order;
1162       if (p->state < ORDER_SPEC)
1163         p->state = ORDER_SPEC;
1164       break;
1165
1166     case_executable:
1167     case_exec_markers:
1168       if (p->state < ORDER_EXEC)
1169         p->state = ORDER_EXEC;
1170       break;
1171
1172     default:
1173       gfc_internal_error
1174         ("Unexpected %s statement in verify_st_order() at %C",
1175          gfc_ascii_statement (st));
1176     }
1177
1178   /* All is well, record the statement in case we need it next time.  */
1179   p->where = gfc_current_locus;
1180   p->last_statement = st;
1181   return SUCCESS;
1182
1183 order:
1184   gfc_error ("%s statement at %C cannot follow %s statement at %L",
1185              gfc_ascii_statement (st),
1186              gfc_ascii_statement (p->last_statement), &p->where);
1187
1188   return FAILURE;
1189 }
1190
1191
1192 /* Handle an unexpected end of file.  This is a show-stopper...  */
1193
1194 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1195
1196 static void
1197 unexpected_eof (void)
1198 {
1199   gfc_state_data *p;
1200
1201   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1202
1203   /* Memory cleanup.  Move to "second to last".  */
1204   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1205        p = p->previous);
1206
1207   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1208   gfc_done_2 ();
1209
1210   longjmp (eof_buf, 1);
1211 }
1212
1213
1214 /* Parse a derived type.  */
1215
1216 static void
1217 parse_derived (void)
1218 {
1219   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1220   gfc_statement st;
1221   gfc_component *c;
1222   gfc_state_data s;
1223
1224   error_flag = 0;
1225
1226   accept_statement (ST_DERIVED_DECL);
1227   push_state (&s, COMP_DERIVED, gfc_new_block);
1228
1229   gfc_new_block->component_access = ACCESS_PUBLIC;
1230   seen_private = 0;
1231   seen_sequence = 0;
1232   seen_component = 0;
1233
1234   compiling_type = 1;
1235
1236   while (compiling_type)
1237     {
1238       st = next_statement ();
1239       switch (st)
1240         {
1241         case ST_NONE:
1242           unexpected_eof ();
1243
1244         case ST_DATA_DECL:
1245           accept_statement (st);
1246           seen_component = 1;
1247           break;
1248
1249         case ST_END_TYPE:
1250           compiling_type = 0;
1251
1252           if (!seen_component)
1253             {
1254               gfc_error ("Derived type definition at %C has no components");
1255               error_flag = 1;
1256             }
1257
1258           accept_statement (ST_END_TYPE);
1259           break;
1260
1261         case ST_PRIVATE:
1262           if (gfc_find_state (COMP_MODULE) == FAILURE)
1263             {
1264               gfc_error
1265                 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1266               error_flag = 1;
1267               break;
1268             }
1269
1270           if (seen_component)
1271             {
1272               gfc_error ("PRIVATE statement at %C must precede "
1273                          "structure components");
1274               error_flag = 1;
1275               break;
1276             }
1277
1278           if (seen_private)
1279             {
1280               gfc_error ("Duplicate PRIVATE statement at %C");
1281               error_flag = 1;
1282             }
1283
1284           s.sym->component_access = ACCESS_PRIVATE;
1285           accept_statement (ST_PRIVATE);
1286           seen_private = 1;
1287           break;
1288
1289         case ST_SEQUENCE:
1290           if (seen_component)
1291             {
1292               gfc_error ("SEQUENCE statement at %C must precede "
1293                          "structure components");
1294               error_flag = 1;
1295               break;
1296             }
1297
1298           if (gfc_current_block ()->attr.sequence)
1299             gfc_warning ("SEQUENCE attribute at %C already specified in "
1300                          "TYPE statement");
1301
1302           if (seen_sequence)
1303             {
1304               gfc_error ("Duplicate SEQUENCE statement at %C");
1305               error_flag = 1;
1306             }
1307
1308           seen_sequence = 1;
1309           gfc_add_sequence (&gfc_current_block ()->attr, 
1310                             gfc_current_block ()->name, NULL);
1311           break;
1312
1313         default:
1314           unexpected_statement (st);
1315           break;
1316         }
1317     }
1318
1319   /* Sanity checks on the structure.  If the structure has the
1320      SEQUENCE attribute, then all component structures must also have
1321      SEQUENCE.  */
1322   if (error_flag == 0 && gfc_current_block ()->attr.sequence)
1323     for (c = gfc_current_block ()->components; c; c = c->next)
1324       {
1325         if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
1326           {
1327             gfc_error
1328               ("Component %s of SEQUENCE type declared at %C does not "
1329                "have the SEQUENCE attribute", c->ts.derived->name);
1330           }
1331       }
1332
1333   pop_state ();
1334 }
1335
1336
1337
1338 /* Parse an interface.  We must be able to deal with the possibility
1339    of recursive interfaces.  The parse_spec() subroutine is mutually
1340    recursive with parse_interface().  */
1341
1342 static gfc_statement parse_spec (gfc_statement);
1343
1344 static void
1345 parse_interface (void)
1346 {
1347   gfc_compile_state new_state, current_state;
1348   gfc_symbol *prog_unit, *sym;
1349   gfc_interface_info save;
1350   gfc_state_data s1, s2;
1351   gfc_statement st;
1352
1353   accept_statement (ST_INTERFACE);
1354
1355   current_interface.ns = gfc_current_ns;
1356   save = current_interface;
1357
1358   sym = (current_interface.type == INTERFACE_GENERIC
1359          || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
1360
1361   push_state (&s1, COMP_INTERFACE, sym);
1362   current_state = COMP_NONE;
1363
1364 loop:
1365   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1366
1367   st = next_statement ();
1368   switch (st)
1369     {
1370     case ST_NONE:
1371       unexpected_eof ();
1372
1373     case ST_SUBROUTINE:
1374       new_state = COMP_SUBROUTINE;
1375       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1376                                   gfc_new_block->formal, NULL);
1377       break;
1378
1379     case ST_FUNCTION:
1380       new_state = COMP_FUNCTION;
1381       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1382                                   gfc_new_block->formal, NULL);
1383       break;
1384
1385     case ST_MODULE_PROC:        /* The module procedure matcher makes
1386                                    sure the context is correct.  */
1387       accept_statement (st);
1388       gfc_free_namespace (gfc_current_ns);
1389       goto loop;
1390
1391     case ST_END_INTERFACE:
1392       gfc_free_namespace (gfc_current_ns);
1393       gfc_current_ns = current_interface.ns;
1394       goto done;
1395
1396     default:
1397       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1398                  gfc_ascii_statement (st));
1399       reject_statement ();
1400       gfc_free_namespace (gfc_current_ns);
1401       goto loop;
1402     }
1403
1404
1405   /* Make sure that a generic interface has only subroutines or
1406      functions and that the generic name has the right attribute.  */
1407   if (current_interface.type == INTERFACE_GENERIC)
1408     {
1409       if (current_state == COMP_NONE)
1410         {
1411           if (new_state == COMP_FUNCTION)
1412             gfc_add_function (&sym->attr, sym->name, NULL);
1413           else if (new_state == COMP_SUBROUTINE)
1414             gfc_add_subroutine (&sym->attr, sym->name, NULL);
1415
1416           current_state = new_state;
1417         }
1418       else
1419         {
1420           if (new_state != current_state)
1421             {
1422               if (new_state == COMP_SUBROUTINE)
1423                 gfc_error
1424                   ("SUBROUTINE at %C does not belong in a generic function "
1425                    "interface");
1426
1427               if (new_state == COMP_FUNCTION)
1428                 gfc_error
1429                   ("FUNCTION at %C does not belong in a generic subroutine "
1430                    "interface");
1431             }
1432         }
1433     }
1434
1435   push_state (&s2, new_state, gfc_new_block);
1436   accept_statement (st);
1437   prog_unit = gfc_new_block;
1438   prog_unit->formal_ns = gfc_current_ns;
1439
1440 decl:
1441   /* Read data declaration statements.  */
1442   st = parse_spec (ST_NONE);
1443
1444   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1445     {
1446       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1447                  gfc_ascii_statement (st));
1448       reject_statement ();
1449       goto decl;
1450     }
1451
1452   current_interface = save;
1453   gfc_add_interface (prog_unit);
1454
1455   pop_state ();
1456   goto loop;
1457
1458 done:
1459   pop_state ();
1460 }
1461
1462
1463 /* Parse a set of specification statements.  Returns the statement
1464    that doesn't fit.  */
1465
1466 static gfc_statement
1467 parse_spec (gfc_statement st)
1468 {
1469   st_state ss;
1470
1471   verify_st_order (&ss, ST_NONE);
1472   if (st == ST_NONE)
1473     st = next_statement ();
1474
1475 loop:
1476   switch (st)
1477     {
1478     case ST_NONE:
1479       unexpected_eof ();
1480
1481     case ST_FORMAT:
1482     case ST_ENTRY:
1483     case ST_DATA:       /* Not allowed in interfaces */
1484       if (gfc_current_state () == COMP_INTERFACE)
1485         break;
1486
1487       /* Fall through */
1488
1489     case ST_USE:
1490     case ST_IMPLICIT_NONE:
1491     case ST_IMPLICIT:
1492     case ST_PARAMETER:
1493     case ST_PUBLIC:
1494     case ST_PRIVATE:
1495     case ST_DERIVED_DECL:
1496     case_decl:
1497       if (verify_st_order (&ss, st) == FAILURE)
1498         {
1499           reject_statement ();
1500           st = next_statement ();
1501           goto loop;
1502         }
1503
1504       switch (st)
1505         {
1506         case ST_INTERFACE:
1507           parse_interface ();
1508           break;
1509
1510         case ST_DERIVED_DECL:
1511           parse_derived ();
1512           break;
1513
1514         case ST_PUBLIC:
1515         case ST_PRIVATE:
1516           if (gfc_current_state () != COMP_MODULE)
1517             {
1518               gfc_error ("%s statement must appear in a MODULE",
1519                          gfc_ascii_statement (st));
1520               break;
1521             }
1522
1523           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1524             {
1525               gfc_error ("%s statement at %C follows another accessibility "
1526                          "specification", gfc_ascii_statement (st));
1527               break;
1528             }
1529
1530           gfc_current_ns->default_access = (st == ST_PUBLIC)
1531             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1532
1533           break;
1534
1535         default:
1536           break;
1537         }
1538
1539       accept_statement (st);
1540       st = next_statement ();
1541       goto loop;
1542
1543     default:
1544       break;
1545     }
1546
1547   return st;
1548 }
1549
1550
1551 /* Parse a WHERE block, (not a simple WHERE statement).  */
1552
1553 static void
1554 parse_where_block (void)
1555 {
1556   int seen_empty_else;
1557   gfc_code *top, *d;
1558   gfc_state_data s;
1559   gfc_statement st;
1560
1561   accept_statement (ST_WHERE_BLOCK);
1562   top = gfc_state_stack->tail;
1563
1564   push_state (&s, COMP_WHERE, gfc_new_block);
1565
1566   d = add_statement ();
1567   d->expr = top->expr;
1568   d->op = EXEC_WHERE;
1569
1570   top->expr = NULL;
1571   top->block = d;
1572
1573   seen_empty_else = 0;
1574
1575   do
1576     {
1577       st = next_statement ();
1578       switch (st)
1579         {
1580         case ST_NONE:
1581           unexpected_eof ();
1582
1583         case ST_WHERE_BLOCK:
1584           parse_where_block ();
1585           /* Fall through */
1586
1587         case ST_ASSIGNMENT:
1588         case ST_WHERE:
1589           accept_statement (st);
1590           break;
1591
1592         case ST_ELSEWHERE:
1593           if (seen_empty_else)
1594             {
1595               gfc_error
1596                 ("ELSEWHERE statement at %C follows previous unmasked "
1597                  "ELSEWHERE");
1598               break;
1599             }
1600
1601           if (new_st.expr == NULL)
1602             seen_empty_else = 1;
1603
1604           d = new_level (gfc_state_stack->head);
1605           d->op = EXEC_WHERE;
1606           d->expr = new_st.expr;
1607
1608           accept_statement (st);
1609
1610           break;
1611
1612         case ST_END_WHERE:
1613           accept_statement (st);
1614           break;
1615
1616         default:
1617           gfc_error ("Unexpected %s statement in WHERE block at %C",
1618                      gfc_ascii_statement (st));
1619           reject_statement ();
1620           break;
1621         }
1622
1623     }
1624   while (st != ST_END_WHERE);
1625
1626   pop_state ();
1627 }
1628
1629
1630 /* Parse a FORALL block (not a simple FORALL statement).  */
1631
1632 static void
1633 parse_forall_block (void)
1634 {
1635   gfc_code *top, *d;
1636   gfc_state_data s;
1637   gfc_statement st;
1638
1639   accept_statement (ST_FORALL_BLOCK);
1640   top = gfc_state_stack->tail;
1641
1642   push_state (&s, COMP_FORALL, gfc_new_block);
1643
1644   d = add_statement ();
1645   d->op = EXEC_FORALL;
1646   top->block = d;
1647
1648   do
1649     {
1650       st = next_statement ();
1651       switch (st)
1652         {
1653
1654         case ST_ASSIGNMENT:
1655         case ST_POINTER_ASSIGNMENT:
1656         case ST_WHERE:
1657         case ST_FORALL:
1658           accept_statement (st);
1659           break;
1660
1661         case ST_WHERE_BLOCK:
1662           parse_where_block ();
1663           break;
1664
1665         case ST_FORALL_BLOCK:
1666           parse_forall_block ();
1667           break;
1668
1669         case ST_END_FORALL:
1670           accept_statement (st);
1671           break;
1672
1673         case ST_NONE:
1674           unexpected_eof ();
1675
1676         default:
1677           gfc_error ("Unexpected %s statement in FORALL block at %C",
1678                      gfc_ascii_statement (st));
1679
1680           reject_statement ();
1681           break;
1682         }
1683     }
1684   while (st != ST_END_FORALL);
1685
1686   pop_state ();
1687 }
1688
1689
1690 static gfc_statement parse_executable (gfc_statement);
1691
1692 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
1693
1694 static void
1695 parse_if_block (void)
1696 {
1697   gfc_code *top, *d;
1698   gfc_statement st;
1699   locus else_locus;
1700   gfc_state_data s;
1701   int seen_else;
1702
1703   seen_else = 0;
1704   accept_statement (ST_IF_BLOCK);
1705
1706   top = gfc_state_stack->tail;
1707   push_state (&s, COMP_IF, gfc_new_block);
1708
1709   new_st.op = EXEC_IF;
1710   d = add_statement ();
1711
1712   d->expr = top->expr;
1713   top->expr = NULL;
1714   top->block = d;
1715
1716   do
1717     {
1718       st = parse_executable (ST_NONE);
1719
1720       switch (st)
1721         {
1722         case ST_NONE:
1723           unexpected_eof ();
1724
1725         case ST_ELSEIF:
1726           if (seen_else)
1727             {
1728               gfc_error
1729                 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1730                  &else_locus);
1731
1732               reject_statement ();
1733               break;
1734             }
1735
1736           d = new_level (gfc_state_stack->head);
1737           d->op = EXEC_IF;
1738           d->expr = new_st.expr;
1739
1740           accept_statement (st);
1741
1742           break;
1743
1744         case ST_ELSE:
1745           if (seen_else)
1746             {
1747               gfc_error ("Duplicate ELSE statements at %L and %C",
1748                          &else_locus);
1749               reject_statement ();
1750               break;
1751             }
1752
1753           seen_else = 1;
1754           else_locus = gfc_current_locus;
1755
1756           d = new_level (gfc_state_stack->head);
1757           d->op = EXEC_IF;
1758
1759           accept_statement (st);
1760
1761           break;
1762
1763         case ST_ENDIF:
1764           break;
1765
1766         default:
1767           unexpected_statement (st);
1768           break;
1769         }
1770     }
1771   while (st != ST_ENDIF);
1772
1773   pop_state ();
1774   accept_statement (st);
1775 }
1776
1777
1778 /* Parse a SELECT block.  */
1779
1780 static void
1781 parse_select_block (void)
1782 {
1783   gfc_statement st;
1784   gfc_code *cp;
1785   gfc_state_data s;
1786
1787   accept_statement (ST_SELECT_CASE);
1788
1789   cp = gfc_state_stack->tail;
1790   push_state (&s, COMP_SELECT, gfc_new_block);
1791
1792   /* Make sure that the next statement is a CASE or END SELECT.  */
1793   for (;;)
1794     {
1795       st = next_statement ();
1796       if (st == ST_NONE)
1797         unexpected_eof ();
1798       if (st == ST_END_SELECT)
1799         {
1800           /* Empty SELECT CASE is OK.  */
1801           accept_statement (st);
1802           pop_state ();
1803           return;
1804         }
1805       if (st == ST_CASE)
1806         break;
1807
1808       gfc_error
1809         ("Expected a CASE or END SELECT statement following SELECT CASE "
1810          "at %C");
1811
1812       reject_statement ();
1813     }
1814
1815   /* At this point, we're got a nonempty select block.  */
1816   cp = new_level (cp);
1817   *cp = new_st;
1818
1819   accept_statement (st);
1820
1821   do
1822     {
1823       st = parse_executable (ST_NONE);
1824       switch (st)
1825         {
1826         case ST_NONE:
1827           unexpected_eof ();
1828
1829         case ST_CASE:
1830           cp = new_level (gfc_state_stack->head);
1831           *cp = new_st;
1832           gfc_clear_new_st ();
1833
1834           accept_statement (st);
1835           /* Fall through */
1836
1837         case ST_END_SELECT:
1838           break;
1839
1840         /* Can't have an executable statement because of
1841            parse_executable().  */
1842         default:
1843           unexpected_statement (st);
1844           break;
1845         }
1846     }
1847   while (st != ST_END_SELECT);
1848
1849   pop_state ();
1850   accept_statement (st);
1851 }
1852
1853
1854 /* Given a symbol, make sure it is not an iteration variable for a DO
1855    statement.  This subroutine is called when the symbol is seen in a
1856    context that causes it to become redefined.  If the symbol is an
1857    iterator, we generate an error message and return nonzero.  */
1858
1859 int 
1860 gfc_check_do_variable (gfc_symtree *st)
1861 {
1862   gfc_state_data *s;
1863
1864   for (s=gfc_state_stack; s; s = s->previous)
1865     if (s->do_variable == st)
1866       {
1867         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
1868                       "loop beginning at %L", st->name, &s->head->loc);
1869         return 1;
1870       }
1871
1872   return 0;
1873 }
1874   
1875
1876 /* Checks to see if the current statement label closes an enddo.
1877    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1878    an error) if it incorrectly closes an ENDDO.  */
1879
1880 static int
1881 check_do_closure (void)
1882 {
1883   gfc_state_data *p;
1884
1885   if (gfc_statement_label == NULL)
1886     return 0;
1887
1888   for (p = gfc_state_stack; p; p = p->previous)
1889     if (p->state == COMP_DO)
1890       break;
1891
1892   if (p == NULL)
1893     return 0;           /* No loops to close */
1894
1895   if (p->ext.end_do_label == gfc_statement_label)
1896     {
1897
1898       if (p == gfc_state_stack)
1899         return 1;
1900
1901       gfc_error
1902         ("End of nonblock DO statement at %C is within another block");
1903       return 2;
1904     }
1905
1906   /* At this point, the label doesn't terminate the innermost loop.
1907      Make sure it doesn't terminate another one.  */
1908   for (; p; p = p->previous)
1909     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
1910       {
1911         gfc_error ("End of nonblock DO statement at %C is interwoven "
1912                    "with another DO loop");
1913         return 2;
1914       }
1915
1916   return 0;
1917 }
1918
1919
1920 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
1921    handled inside of parse_executable(), because they aren't really
1922    loop statements.  */
1923
1924 static void
1925 parse_do_block (void)
1926 {
1927   gfc_statement st;
1928   gfc_code *top;
1929   gfc_state_data s;
1930   gfc_symtree *stree;
1931
1932   s.ext.end_do_label = new_st.label;
1933
1934   if (new_st.ext.iterator != NULL)
1935     stree = new_st.ext.iterator->var->symtree;
1936   else
1937     stree = NULL;
1938
1939   accept_statement (ST_DO);
1940
1941   top = gfc_state_stack->tail;
1942   push_state (&s, COMP_DO, gfc_new_block);
1943
1944   s.do_variable = stree;
1945
1946   top->block = new_level (top);
1947   top->block->op = EXEC_DO;
1948
1949 loop:
1950   st = parse_executable (ST_NONE);
1951
1952   switch (st)
1953     {
1954     case ST_NONE:
1955       unexpected_eof ();
1956
1957     case ST_ENDDO:
1958       if (s.ext.end_do_label != NULL
1959           && s.ext.end_do_label != gfc_statement_label)
1960         gfc_error_now
1961           ("Statement label in ENDDO at %C doesn't match DO label");
1962
1963       if (gfc_statement_label != NULL)
1964         {
1965           new_st.op = EXEC_NOP;
1966           add_statement ();
1967         }
1968       break;
1969
1970     case ST_IMPLIED_ENDDO:
1971       break;
1972
1973     default:
1974       unexpected_statement (st);
1975       goto loop;
1976     }
1977
1978   pop_state ();
1979   accept_statement (st);
1980 }
1981
1982
1983 /* Accept a series of executable statements.  We return the first
1984    statement that doesn't fit to the caller.  Any block statements are
1985    passed on to the correct handler, which usually passes the buck
1986    right back here.  */
1987
1988 static gfc_statement
1989 parse_executable (gfc_statement st)
1990 {
1991   int close_flag;
1992
1993   if (st == ST_NONE)
1994     st = next_statement ();
1995
1996   for (;; st = next_statement ())
1997     {
1998
1999       close_flag = check_do_closure ();
2000       if (close_flag)
2001         switch (st)
2002           {
2003           case ST_GOTO:
2004           case ST_END_PROGRAM:
2005           case ST_RETURN:
2006           case ST_EXIT:
2007           case ST_END_FUNCTION:
2008           case ST_CYCLE:
2009           case ST_PAUSE:
2010           case ST_STOP:
2011           case ST_END_SUBROUTINE:
2012
2013           case ST_DO:
2014           case ST_FORALL:
2015           case ST_WHERE:
2016           case ST_SELECT_CASE:
2017             gfc_error
2018               ("%s statement at %C cannot terminate a non-block DO loop",
2019                gfc_ascii_statement (st));
2020             break;
2021
2022           default:
2023             break;
2024           }
2025
2026       switch (st)
2027         {
2028         case ST_NONE:
2029           unexpected_eof ();
2030
2031         case ST_FORMAT:
2032         case ST_DATA:
2033         case ST_ENTRY:
2034         case_executable:
2035           accept_statement (st);
2036           if (close_flag == 1)
2037             return ST_IMPLIED_ENDDO;
2038           continue;
2039
2040         case ST_IF_BLOCK:
2041           parse_if_block ();
2042           continue;
2043
2044         case ST_SELECT_CASE:
2045           parse_select_block ();
2046           continue;
2047
2048         case ST_DO:
2049           parse_do_block ();
2050           if (check_do_closure () == 1)
2051             return ST_IMPLIED_ENDDO;
2052           continue;
2053
2054         case ST_WHERE_BLOCK:
2055           parse_where_block ();
2056           continue;
2057
2058         case ST_FORALL_BLOCK:
2059           parse_forall_block ();
2060           continue;
2061
2062         default:
2063           break;
2064         }
2065
2066       break;
2067     }
2068
2069   return st;
2070 }
2071
2072
2073 /* Parse a series of contained program units.  */
2074
2075 static void parse_progunit (gfc_statement);
2076
2077
2078 /* Fix the symbols for sibling functions.  These are incorrectly added to
2079    the child namespace as the parser didn't know about this procedure.  */
2080
2081 static void
2082 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2083 {
2084   gfc_namespace *ns;
2085   gfc_symtree *st;
2086   gfc_symbol *old_sym;
2087
2088   sym->attr.referenced = 1;
2089   for (ns = siblings; ns; ns = ns->sibling)
2090     {
2091       gfc_find_sym_tree (sym->name, ns, 0, &st);
2092       if (!st)
2093         continue;
2094
2095       old_sym = st->n.sym;
2096       if ((old_sym->attr.flavor == FL_PROCEDURE
2097            || old_sym->ts.type == BT_UNKNOWN)
2098           && old_sym->ns == ns
2099           && ! old_sym->attr.contained)
2100         {
2101           /* Replace it with the symbol from the parent namespace.  */
2102           st->n.sym = sym;
2103           sym->refs++;
2104
2105           /* Free the old (local) symbol.  */
2106           old_sym->refs--;
2107           if (old_sym->refs == 0)
2108             gfc_free_symbol (old_sym);
2109         }
2110
2111       /* Do the same for any contained procedures.  */
2112       gfc_fixup_sibling_symbols (sym, ns->contained);
2113     }
2114 }
2115
2116 static void
2117 parse_contained (int module)
2118 {
2119   gfc_namespace *ns, *parent_ns;
2120   gfc_state_data s1, s2;
2121   gfc_statement st;
2122   gfc_symbol *sym;
2123   gfc_entry_list *el;
2124
2125   push_state (&s1, COMP_CONTAINS, NULL);
2126   parent_ns = gfc_current_ns;
2127
2128   do
2129     {
2130       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2131
2132       gfc_current_ns->sibling = parent_ns->contained;
2133       parent_ns->contained = gfc_current_ns;
2134
2135       st = next_statement ();
2136
2137       switch (st)
2138         {
2139         case ST_NONE:
2140           unexpected_eof ();
2141
2142         case ST_FUNCTION:
2143         case ST_SUBROUTINE:
2144           accept_statement (st);
2145
2146           push_state (&s2,
2147                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2148                       gfc_new_block);
2149
2150           /* For internal procedures, create/update the symbol in the
2151              parent namespace.  */
2152
2153           if (!module)
2154             {
2155               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2156                 gfc_error
2157                   ("Contained procedure '%s' at %C is already ambiguous",
2158                    gfc_new_block->name);
2159               else
2160                 {
2161                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2162                                          &gfc_new_block->declared_at) ==
2163                       SUCCESS)
2164                     {
2165                       if (st == ST_FUNCTION)
2166                         gfc_add_function (&sym->attr, sym->name,
2167                                           &gfc_new_block->declared_at);
2168                       else
2169                         gfc_add_subroutine (&sym->attr, sym->name,
2170                                             &gfc_new_block->declared_at);
2171                     }
2172                 }
2173
2174               gfc_commit_symbols ();
2175             }
2176           else
2177             sym = gfc_new_block;
2178
2179           /* Mark this as a contained function, so it isn't replaced
2180              by other module functions.  */
2181           sym->attr.contained = 1;
2182           sym->attr.referenced = 1;
2183
2184           parse_progunit (ST_NONE);
2185
2186           /* Fix up any sibling functions that refer to this one.  */
2187           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2188           /* Or refer to any of its alternate entry points.  */
2189           for (el = gfc_current_ns->entries; el; el = el->next)
2190             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2191
2192           gfc_current_ns->code = s2.head;
2193           gfc_current_ns = parent_ns;
2194
2195           pop_state ();
2196           break;
2197
2198         /* These statements are associated with the end of the host
2199            unit.  */
2200         case ST_END_FUNCTION:
2201         case ST_END_MODULE:
2202         case ST_END_PROGRAM:
2203         case ST_END_SUBROUTINE:
2204           accept_statement (st);
2205           break;
2206
2207         default:
2208           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2209                      gfc_ascii_statement (st));
2210           reject_statement ();
2211           break;
2212         }
2213     }
2214   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2215          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2216
2217   /* The first namespace in the list is guaranteed to not have
2218      anything (worthwhile) in it.  */
2219
2220   gfc_current_ns = parent_ns;
2221
2222   ns = gfc_current_ns->contained;
2223   gfc_current_ns->contained = ns->sibling;
2224   gfc_free_namespace (ns);
2225
2226   pop_state ();
2227 }
2228
2229
2230 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2231
2232 static void
2233 parse_progunit (gfc_statement st)
2234 {
2235   gfc_state_data *p;
2236   int n;
2237
2238   st = parse_spec (st);
2239   switch (st)
2240     {
2241     case ST_NONE:
2242       unexpected_eof ();
2243
2244     case ST_CONTAINS:
2245       goto contains;
2246
2247     case_end:
2248       accept_statement (st);
2249       goto done;
2250
2251     default:
2252       break;
2253     }
2254
2255 loop:
2256   for (;;)
2257     {
2258       st = parse_executable (st);
2259
2260       switch (st)
2261         {
2262         case ST_NONE:
2263           unexpected_eof ();
2264
2265         case ST_CONTAINS:
2266           goto contains;
2267
2268         case_end:
2269           accept_statement (st);
2270           goto done;
2271
2272         default:
2273           break;
2274         }
2275
2276       unexpected_statement (st);
2277       reject_statement ();
2278       st = next_statement ();
2279     }
2280
2281 contains:
2282   n = 0;
2283
2284   for (p = gfc_state_stack; p; p = p->previous)
2285     if (p->state == COMP_CONTAINS)
2286       n++;
2287
2288   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2289     n--;
2290
2291   if (n > 0)
2292     {
2293       gfc_error ("CONTAINS statement at %C is already in a contained "
2294                  "program unit");
2295       st = next_statement ();
2296       goto loop;
2297     }
2298
2299   parse_contained (0);
2300
2301 done:
2302   gfc_current_ns->code = gfc_state_stack->head;
2303 }
2304
2305
2306 /* Come here to complain about a global symbol already in use as
2307    something else.  */
2308
2309 static void
2310 global_used (gfc_gsymbol *sym, locus *where)
2311 {
2312   const char *name;
2313
2314   if (where == NULL)
2315     where = &gfc_current_locus;
2316
2317   switch(sym->type)
2318     {
2319     case GSYM_PROGRAM:
2320       name = "PROGRAM";
2321       break;
2322     case GSYM_FUNCTION:
2323       name = "FUNCTION";
2324       break;
2325     case GSYM_SUBROUTINE:
2326       name = "SUBROUTINE";
2327       break;
2328     case GSYM_COMMON:
2329       name = "COMMON";
2330       break;
2331     case GSYM_BLOCK_DATA:
2332       name = "BLOCK DATA";
2333       break;
2334     case GSYM_MODULE:
2335       name = "MODULE";
2336       break;
2337     default:
2338       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2339       name = NULL;
2340     }
2341
2342   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2343            gfc_new_block->name, where, name, &sym->where);
2344 }
2345
2346
2347 /* Parse a block data program unit.  */
2348
2349 static void
2350 parse_block_data (void)
2351 {
2352   gfc_statement st;
2353   static locus blank_locus;
2354   static int blank_block=0;
2355   gfc_gsymbol *s;
2356
2357   gfc_current_ns->proc_name = gfc_new_block;
2358   gfc_current_ns->is_block_data = 1;
2359
2360   if (gfc_new_block == NULL)
2361     {
2362       if (blank_block)
2363        gfc_error ("Blank BLOCK DATA at %C conflicts with "
2364                   "prior BLOCK DATA at %L", &blank_locus);
2365       else
2366        {
2367          blank_block = 1;
2368          blank_locus = gfc_current_locus;
2369        }
2370     }
2371   else
2372     {
2373       s = gfc_get_gsymbol (gfc_new_block->name);
2374       if (s->type != GSYM_UNKNOWN)
2375        global_used(s, NULL);
2376       else
2377        {
2378          s->type = GSYM_BLOCK_DATA;
2379          s->where = gfc_current_locus;
2380        }
2381     }
2382
2383   st = parse_spec (ST_NONE);
2384
2385   while (st != ST_END_BLOCK_DATA)
2386     {
2387       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2388                  gfc_ascii_statement (st));
2389       reject_statement ();
2390       st = next_statement ();
2391     }
2392 }
2393
2394
2395 /* Parse a module subprogram.  */
2396
2397 static void
2398 parse_module (void)
2399 {
2400   gfc_statement st;
2401   gfc_gsymbol *s;
2402
2403   s = gfc_get_gsymbol (gfc_new_block->name);
2404   if (s->type != GSYM_UNKNOWN)
2405     global_used(s, NULL);
2406   else
2407     {
2408       s->type = GSYM_MODULE;
2409       s->where = gfc_current_locus;
2410     }
2411
2412   st = parse_spec (ST_NONE);
2413
2414 loop:
2415   switch (st)
2416     {
2417     case ST_NONE:
2418       unexpected_eof ();
2419
2420     case ST_CONTAINS:
2421       parse_contained (1);
2422       break;
2423
2424     case ST_END_MODULE:
2425       accept_statement (st);
2426       break;
2427
2428     default:
2429       gfc_error ("Unexpected %s statement in MODULE at %C",
2430                  gfc_ascii_statement (st));
2431
2432       reject_statement ();
2433       st = next_statement ();
2434       goto loop;
2435     }
2436 }
2437
2438
2439 /* Add a procedure name to the global symbol table.  */
2440
2441 static void
2442 add_global_procedure (int sub)
2443 {
2444   gfc_gsymbol *s;
2445
2446   s = gfc_get_gsymbol(gfc_new_block->name);
2447
2448   if (s->type != GSYM_UNKNOWN)
2449     global_used(s, NULL);
2450   else
2451     {
2452       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2453       s->where = gfc_current_locus;
2454     }
2455 }
2456
2457
2458 /* Add a program to the global symbol table.  */
2459
2460 static void
2461 add_global_program (void)
2462 {
2463   gfc_gsymbol *s;
2464
2465   if (gfc_new_block == NULL)
2466     return;
2467   s = gfc_get_gsymbol (gfc_new_block->name);
2468
2469   if (s->type != GSYM_UNKNOWN)
2470     global_used(s, NULL);
2471   else
2472     {
2473       s->type = GSYM_PROGRAM;
2474       s->where = gfc_current_locus;
2475     }
2476 }
2477
2478
2479 /* Top level parser.  */
2480
2481 try
2482 gfc_parse_file (void)
2483 {
2484   int seen_program, errors_before, errors;
2485   gfc_state_data top, s;
2486   gfc_statement st;
2487   locus prog_locus;
2488
2489   top.state = COMP_NONE;
2490   top.sym = NULL;
2491   top.previous = NULL;
2492   top.head = top.tail = NULL;
2493   top.do_variable = NULL;
2494
2495   gfc_state_stack = &top;
2496
2497   gfc_clear_new_st ();
2498
2499   gfc_statement_label = NULL;
2500
2501   if (setjmp (eof_buf))
2502     return FAILURE;     /* Come here on unexpected EOF */
2503
2504   seen_program = 0;
2505
2506   /* Exit early for empty files.  */
2507   if (gfc_at_eof ())
2508     goto done;
2509
2510 loop:
2511   gfc_init_2 ();
2512   st = next_statement ();
2513   switch (st)
2514     {
2515     case ST_NONE:
2516       gfc_done_2 ();
2517       goto done;
2518
2519     case ST_PROGRAM:
2520       if (seen_program)
2521         goto duplicate_main;
2522       seen_program = 1;
2523       prog_locus = gfc_current_locus;
2524
2525       push_state (&s, COMP_PROGRAM, gfc_new_block);
2526       accept_statement (st);
2527       add_global_program ();
2528       parse_progunit (ST_NONE);
2529       break;
2530
2531     case ST_SUBROUTINE:
2532       add_global_procedure (1);
2533       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
2534       accept_statement (st);
2535       parse_progunit (ST_NONE);
2536       break;
2537
2538     case ST_FUNCTION:
2539       add_global_procedure (0);
2540       push_state (&s, COMP_FUNCTION, gfc_new_block);
2541       accept_statement (st);
2542       parse_progunit (ST_NONE);
2543       break;
2544
2545     case ST_BLOCK_DATA:
2546       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
2547       accept_statement (st);
2548       parse_block_data ();
2549       break;
2550
2551     case ST_MODULE:
2552       push_state (&s, COMP_MODULE, gfc_new_block);
2553       accept_statement (st);
2554
2555       gfc_get_errors (NULL, &errors_before);
2556       parse_module ();
2557       break;
2558
2559     /* Anything else starts a nameless main program block.  */
2560     default:
2561       if (seen_program)
2562         goto duplicate_main;
2563       seen_program = 1;
2564       prog_locus = gfc_current_locus;
2565
2566       push_state (&s, COMP_PROGRAM, gfc_new_block);
2567       parse_progunit (st);
2568       break;
2569     }
2570
2571   gfc_current_ns->code = s.head;
2572
2573   gfc_resolve (gfc_current_ns);
2574
2575   /* Dump the parse tree if requested.  */
2576   if (gfc_option.verbose)
2577     gfc_show_namespace (gfc_current_ns);
2578
2579   gfc_get_errors (NULL, &errors);
2580   if (s.state == COMP_MODULE)
2581     {
2582       gfc_dump_module (s.sym->name, errors_before == errors);
2583       if (errors == 0 && ! gfc_option.flag_no_backend)
2584         gfc_generate_module_code (gfc_current_ns);
2585     }
2586   else
2587     {
2588       if (errors == 0 && ! gfc_option.flag_no_backend)
2589         gfc_generate_code (gfc_current_ns);
2590     }
2591
2592   pop_state ();
2593   gfc_done_2 ();
2594   goto loop;
2595
2596 done:
2597   return SUCCESS;
2598
2599 duplicate_main:
2600   /* If we see a duplicate main program, shut down.  If the second
2601      instance is an implied main program, ie data decls or executable
2602      statements, we're in for lots of errors.  */
2603   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
2604   reject_statement ();
2605   gfc_done_2 ();
2606   return SUCCESS;
2607 }