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