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