?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2006-03-15 Paul Brook <paul@codesourcery.com>
[official-gcc.git] / gcc / fortran / parse.c
blobb120bbb77efadefa088dcb5a60232c807d1050d6
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 gfc_commit_symbols ();
2352 gfc_warning_check ();
2353 st = next_statement ();
2354 }
2355 return st;
2356 }
2357
2358
2359 /* Parse the statements of OpenMP atomic directive. */
2360
2361 static void
2362 parse_omp_atomic (void)
2363 {
2364 gfc_statement st;
2365 gfc_code *cp, *np;
2366 gfc_state_data s;
2367
2368 accept_statement (ST_OMP_ATOMIC);
2369
2370 cp = gfc_state_stack->tail;
2371 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2372 np = new_level (cp);
2373 np->op = cp->op;
2374 np->block = NULL;
2375
2376 for (;;)
2377 {
2378 st = next_statement ();
2379 if (st == ST_NONE)
2380 unexpected_eof ();
2381 else if (st == ST_ASSIGNMENT)
2382 break;
2383 else
2384 unexpected_statement (st);
2385 }
2386
2387 accept_statement (st);
2388
2389 pop_state ();
2390 }
2391
2392
2393 /* Parse the statements of an OpenMP structured block. */
2394
2395 static void
2396 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2397 {
2398 gfc_statement st, omp_end_st;
2399 gfc_code *cp, *np;
2400 gfc_state_data s;
2401
2402 accept_statement (omp_st);
2403
2404 cp = gfc_state_stack->tail;
2405 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2406 np = new_level (cp);
2407 np->op = cp->op;
2408 np->block = NULL;
2409
2410 switch (omp_st)
2411 {
2412 case ST_OMP_PARALLEL:
2413 omp_end_st = ST_OMP_END_PARALLEL;
2414 break;
2415 case ST_OMP_PARALLEL_SECTIONS:
2416 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2417 break;
2418 case ST_OMP_SECTIONS:
2419 omp_end_st = ST_OMP_END_SECTIONS;
2420 break;
2421 case ST_OMP_ORDERED:
2422 omp_end_st = ST_OMP_END_ORDERED;
2423 break;
2424 case ST_OMP_CRITICAL:
2425 omp_end_st = ST_OMP_END_CRITICAL;
2426 break;
2427 case ST_OMP_MASTER:
2428 omp_end_st = ST_OMP_END_MASTER;
2429 break;
2430 case ST_OMP_SINGLE:
2431 omp_end_st = ST_OMP_END_SINGLE;
2432 break;
2433 case ST_OMP_WORKSHARE:
2434 omp_end_st = ST_OMP_END_WORKSHARE;
2435 break;
2436 case ST_OMP_PARALLEL_WORKSHARE:
2437 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2438 break;
2439 default:
2440 gcc_unreachable ();
2441 }
2442
2443 do
2444 {
2445 if (workshare_stmts_only)
2446 {
2447 /* Inside of !$omp workshare, only
2448 scalar assignments
2449 array assignments
2450 where statements and constructs
2451 forall statements and constructs
2452 !$omp atomic
2453 !$omp critical
2454 !$omp parallel
2455 are allowed. For !$omp critical these
2456 restrictions apply recursively. */
2457 bool cycle = true;
2458
2459 st = next_statement ();
2460 for (;;)
2461 {
2462 switch (st)
2463 {
2464 case ST_NONE:
2465 unexpected_eof ();
2466
2467 case ST_ASSIGNMENT:
2468 case ST_WHERE:
2469 case ST_FORALL:
2470 accept_statement (st);
2471 break;
2472
2473 case ST_WHERE_BLOCK:
2474 parse_where_block ();
2475 break;
2476
2477 case ST_FORALL_BLOCK:
2478 parse_forall_block ();
2479 break;
2480
2481 case ST_OMP_PARALLEL:
2482 case ST_OMP_PARALLEL_SECTIONS:
2483 parse_omp_structured_block (st, false);
2484 break;
2485
2486 case ST_OMP_PARALLEL_WORKSHARE:
2487 case ST_OMP_CRITICAL:
2488 parse_omp_structured_block (st, true);
2489 break;
2490
2491 case ST_OMP_PARALLEL_DO:
2492 st = parse_omp_do (st);
2493 continue;
2494
2495 case ST_OMP_ATOMIC:
2496 parse_omp_atomic ();
2497 break;
2498
2499 default:
2500 cycle = false;
2501 break;
2502 }
2503
2504 if (!cycle)
2505 break;
2506
2507 st = next_statement ();
2508 }
2509 }
2510 else
2511 st = parse_executable (ST_NONE);
2512 if (st == ST_NONE)
2513 unexpected_eof ();
2514 else if (st == ST_OMP_SECTION
2515 && (omp_st == ST_OMP_SECTIONS
2516 || omp_st == ST_OMP_PARALLEL_SECTIONS))
2517 {
2518 np = new_level (np);
2519 np->op = cp->op;
2520 np->block = NULL;
2521 }
2522 else if (st != omp_end_st)
2523 unexpected_statement (st);
2524 }
2525 while (st != omp_end_st);
2526
2527 switch (new_st.op)
2528 {
2529 case EXEC_OMP_END_NOWAIT:
2530 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2531 break;
2532 case EXEC_OMP_CRITICAL:
2533 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2534 || (new_st.ext.omp_name != NULL
2535 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2536 gfc_error ("Name after !$omp critical and !$omp end critical does"
2537 " not match at %C");
2538 gfc_free ((char *) new_st.ext.omp_name);
2539 break;
2540 case EXEC_OMP_END_SINGLE:
2541 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2542 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2543 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2544 gfc_free_omp_clauses (new_st.ext.omp_clauses);
2545 break;
2546 case EXEC_NOP:
2547 break;
2548 default:
2549 gcc_unreachable ();
2550 }
2551
2552 gfc_clear_new_st ();
2553 gfc_commit_symbols ();
2554 gfc_warning_check ();
2555 pop_state ();
2556 }
2557
2558
2559 /* Accept a series of executable statements. We return the first
2560 statement that doesn't fit to the caller. Any block statements are
2561 passed on to the correct handler, which usually passes the buck
2562 right back here. */
2563
2564 static gfc_statement
2565 parse_executable (gfc_statement st)
2566 {
2567 int close_flag;
2568
2569 if (st == ST_NONE)
2570 st = next_statement ();
2571
2572 for (;;)
2573 {
2574 close_flag = check_do_closure ();
2575 if (close_flag)
2576 switch (st)
2577 {
2578 case ST_GOTO:
2579 case ST_END_PROGRAM:
2580 case ST_RETURN:
2581 case ST_EXIT:
2582 case ST_END_FUNCTION:
2583 case ST_CYCLE:
2584 case ST_PAUSE:
2585 case ST_STOP:
2586 case ST_END_SUBROUTINE:
2587
2588 case ST_DO:
2589 case ST_FORALL:
2590 case ST_WHERE:
2591 case ST_SELECT_CASE:
2592 gfc_error
2593 ("%s statement at %C cannot terminate a non-block DO loop",
2594 gfc_ascii_statement (st));
2595 break;
2596
2597 default:
2598 break;
2599 }
2600
2601 switch (st)
2602 {
2603 case ST_NONE:
2604 unexpected_eof ();
2605
2606 case ST_FORMAT:
2607 case ST_DATA:
2608 case ST_ENTRY:
2609 case_executable:
2610 accept_statement (st);
2611 if (close_flag == 1)
2612 return ST_IMPLIED_ENDDO;
2613 break;
2614
2615 case ST_IF_BLOCK:
2616 parse_if_block ();
2617 break;
2618
2619 case ST_SELECT_CASE:
2620 parse_select_block ();
2621 break;
2622
2623 case ST_DO:
2624 parse_do_block ();
2625 if (check_do_closure () == 1)
2626 return ST_IMPLIED_ENDDO;
2627 break;
2628
2629 case ST_WHERE_BLOCK:
2630 parse_where_block ();
2631 break;
2632
2633 case ST_FORALL_BLOCK:
2634 parse_forall_block ();
2635 break;
2636
2637 case ST_OMP_PARALLEL:
2638 case ST_OMP_PARALLEL_SECTIONS:
2639 case ST_OMP_SECTIONS:
2640 case ST_OMP_ORDERED:
2641 case ST_OMP_CRITICAL:
2642 case ST_OMP_MASTER:
2643 case ST_OMP_SINGLE:
2644 parse_omp_structured_block (st, false);
2645 break;
2646
2647 case ST_OMP_WORKSHARE:
2648 case ST_OMP_PARALLEL_WORKSHARE:
2649 parse_omp_structured_block (st, true);
2650 break;
2651
2652 case ST_OMP_DO:
2653 case ST_OMP_PARALLEL_DO:
2654 st = parse_omp_do (st);
2655 if (st == ST_IMPLIED_ENDDO)
2656 return st;
2657 continue;
2658
2659 case ST_OMP_ATOMIC:
2660 parse_omp_atomic ();
2661 break;
2662
2663 default:
2664 return st;
2665 }
2666
2667 st = next_statement ();
2668 }
2669 }
2670
2671
2672 /* Parse a series of contained program units. */
2673
2674 static void parse_progunit (gfc_statement);
2675
2676
2677 /* Fix the symbols for sibling functions. These are incorrectly added to
2678 the child namespace as the parser didn't know about this procedure. */
2679
2680 static void
2681 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2682 {
2683 gfc_namespace *ns;
2684 gfc_symtree *st;
2685 gfc_symbol *old_sym;
2686
2687 sym->attr.referenced = 1;
2688 for (ns = siblings; ns; ns = ns->sibling)
2689 {
2690 gfc_find_sym_tree (sym->name, ns, 0, &st);
2691 if (!st)
2692 continue;
2693
2694 old_sym = st->n.sym;
2695 if ((old_sym->attr.flavor == FL_PROCEDURE
2696 || old_sym->ts.type == BT_UNKNOWN)
2697 && old_sym->ns == ns
2698 && ! old_sym->attr.contained)
2699 {
2700 /* Replace it with the symbol from the parent namespace. */
2701 st->n.sym = sym;
2702 sym->refs++;
2703
2704 /* Free the old (local) symbol. */
2705 old_sym->refs--;
2706 if (old_sym->refs == 0)
2707 gfc_free_symbol (old_sym);
2708 }
2709
2710 /* Do the same for any contained procedures. */
2711 gfc_fixup_sibling_symbols (sym, ns->contained);
2712 }
2713 }
2714
2715 static void
2716 parse_contained (int module)
2717 {
2718 gfc_namespace *ns, *parent_ns;
2719 gfc_state_data s1, s2;
2720 gfc_statement st;
2721 gfc_symbol *sym;
2722 gfc_entry_list *el;
2723
2724 push_state (&s1, COMP_CONTAINS, NULL);
2725 parent_ns = gfc_current_ns;
2726
2727 do
2728 {
2729 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2730
2731 gfc_current_ns->sibling = parent_ns->contained;
2732 parent_ns->contained = gfc_current_ns;
2733
2734 st = next_statement ();
2735
2736 switch (st)
2737 {
2738 case ST_NONE:
2739 unexpected_eof ();
2740
2741 case ST_FUNCTION:
2742 case ST_SUBROUTINE:
2743 accept_statement (st);
2744
2745 push_state (&s2,
2746 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2747 gfc_new_block);
2748
2749 /* For internal procedures, create/update the symbol in the
2750 parent namespace. */
2751
2752 if (!module)
2753 {
2754 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2755 gfc_error
2756 ("Contained procedure '%s' at %C is already ambiguous",
2757 gfc_new_block->name);
2758 else
2759 {
2760 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2761 &gfc_new_block->declared_at) ==
2762 SUCCESS)
2763 {
2764 if (st == ST_FUNCTION)
2765 gfc_add_function (&sym->attr, sym->name,
2766 &gfc_new_block->declared_at);
2767 else
2768 gfc_add_subroutine (&sym->attr, sym->name,
2769 &gfc_new_block->declared_at);
2770 }
2771 }
2772
2773 gfc_commit_symbols ();
2774 }
2775 else
2776 sym = gfc_new_block;
2777
2778 /* Mark this as a contained function, so it isn't replaced
2779 by other module functions. */
2780 sym->attr.contained = 1;
2781 sym->attr.referenced = 1;
2782
2783 parse_progunit (ST_NONE);
2784
2785 /* Fix up any sibling functions that refer to this one. */
2786 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2787 /* Or refer to any of its alternate entry points. */
2788 for (el = gfc_current_ns->entries; el; el = el->next)
2789 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2790
2791 gfc_current_ns->code = s2.head;
2792 gfc_current_ns = parent_ns;
2793
2794 pop_state ();
2795 break;
2796
2797 /* These statements are associated with the end of the host
2798 unit. */
2799 case ST_END_FUNCTION:
2800 case ST_END_MODULE:
2801 case ST_END_PROGRAM:
2802 case ST_END_SUBROUTINE:
2803 accept_statement (st);
2804 break;
2805
2806 default:
2807 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2808 gfc_ascii_statement (st));
2809 reject_statement ();
2810 break;
2811 }
2812 }
2813 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2814 && st != ST_END_MODULE && st != ST_END_PROGRAM);
2815
2816 /* The first namespace in the list is guaranteed to not have
2817 anything (worthwhile) in it. */
2818
2819 gfc_current_ns = parent_ns;
2820
2821 ns = gfc_current_ns->contained;
2822 gfc_current_ns->contained = ns->sibling;
2823 gfc_free_namespace (ns);
2824
2825 pop_state ();
2826 }
2827
2828
2829 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2830
2831 static void
2832 parse_progunit (gfc_statement st)
2833 {
2834 gfc_state_data *p;
2835 int n;
2836
2837 st = parse_spec (st);
2838 switch (st)
2839 {
2840 case ST_NONE:
2841 unexpected_eof ();
2842
2843 case ST_CONTAINS:
2844 goto contains;
2845
2846 case_end:
2847 accept_statement (st);
2848 goto done;
2849
2850 default:
2851 break;
2852 }
2853
2854 loop:
2855 for (;;)
2856 {
2857 st = parse_executable (st);
2858
2859 switch (st)
2860 {
2861 case ST_NONE:
2862 unexpected_eof ();
2863
2864 case ST_CONTAINS:
2865 goto contains;
2866
2867 case_end:
2868 accept_statement (st);
2869 goto done;
2870
2871 default:
2872 break;
2873 }
2874
2875 unexpected_statement (st);
2876 reject_statement ();
2877 st = next_statement ();
2878 }
2879
2880 contains:
2881 n = 0;
2882
2883 for (p = gfc_state_stack; p; p = p->previous)
2884 if (p->state == COMP_CONTAINS)
2885 n++;
2886
2887 if (gfc_find_state (COMP_MODULE) == SUCCESS)
2888 n--;
2889
2890 if (n > 0)
2891 {
2892 gfc_error ("CONTAINS statement at %C is already in a contained "
2893 "program unit");
2894 st = next_statement ();
2895 goto loop;
2896 }
2897
2898 parse_contained (0);
2899
2900 done:
2901 gfc_current_ns->code = gfc_state_stack->head;
2902 }
2903
2904
2905 /* Come here to complain about a global symbol already in use as
2906 something else. */
2907
2908 void
2909 global_used (gfc_gsymbol *sym, locus *where)
2910 {
2911 const char *name;
2912
2913 if (where == NULL)
2914 where = &gfc_current_locus;
2915
2916 switch(sym->type)
2917 {
2918 case GSYM_PROGRAM:
2919 name = "PROGRAM";
2920 break;
2921 case GSYM_FUNCTION:
2922 name = "FUNCTION";
2923 break;
2924 case GSYM_SUBROUTINE:
2925 name = "SUBROUTINE";
2926 break;
2927 case GSYM_COMMON:
2928 name = "COMMON";
2929 break;
2930 case GSYM_BLOCK_DATA:
2931 name = "BLOCK DATA";
2932 break;
2933 case GSYM_MODULE:
2934 name = "MODULE";
2935 break;
2936 default:
2937 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2938 name = NULL;
2939 }
2940
2941 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2942 sym->name, where, name, &sym->where);
2943 }
2944
2945
2946 /* Parse a block data program unit. */
2947
2948 static void
2949 parse_block_data (void)
2950 {
2951 gfc_statement st;
2952 static locus blank_locus;
2953 static int blank_block=0;
2954 gfc_gsymbol *s;
2955
2956 gfc_current_ns->proc_name = gfc_new_block;
2957 gfc_current_ns->is_block_data = 1;
2958
2959 if (gfc_new_block == NULL)
2960 {
2961 if (blank_block)
2962 gfc_error ("Blank BLOCK DATA at %C conflicts with "
2963 "prior BLOCK DATA at %L", &blank_locus);
2964 else
2965 {
2966 blank_block = 1;
2967 blank_locus = gfc_current_locus;
2968 }
2969 }
2970 else
2971 {
2972 s = gfc_get_gsymbol (gfc_new_block->name);
2973 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
2974 global_used(s, NULL);
2975 else
2976 {
2977 s->type = GSYM_BLOCK_DATA;
2978 s->where = gfc_current_locus;
2979 s->defined = 1;
2980 }
2981 }
2982
2983 st = parse_spec (ST_NONE);
2984
2985 while (st != ST_END_BLOCK_DATA)
2986 {
2987 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2988 gfc_ascii_statement (st));
2989 reject_statement ();
2990 st = next_statement ();
2991 }
2992 }
2993
2994
2995 /* Parse a module subprogram. */
2996
2997 static void
2998 parse_module (void)
2999 {
3000 gfc_statement st;
3001 gfc_gsymbol *s;
3002
3003 s = gfc_get_gsymbol (gfc_new_block->name);
3004 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3005 global_used(s, NULL);
3006 else
3007 {
3008 s->type = GSYM_MODULE;
3009 s->where = gfc_current_locus;
3010 s->defined = 1;
3011 }
3012
3013 st = parse_spec (ST_NONE);
3014
3015 loop:
3016 switch (st)
3017 {
3018 case ST_NONE:
3019 unexpected_eof ();
3020
3021 case ST_CONTAINS:
3022 parse_contained (1);
3023 break;
3024
3025 case ST_END_MODULE:
3026 accept_statement (st);
3027 break;
3028
3029 default:
3030 gfc_error ("Unexpected %s statement in MODULE at %C",
3031 gfc_ascii_statement (st));
3032
3033 reject_statement ();
3034 st = next_statement ();
3035 goto loop;
3036 }
3037 }
3038
3039
3040 /* Add a procedure name to the global symbol table. */
3041
3042 static void
3043 add_global_procedure (int sub)
3044 {
3045 gfc_gsymbol *s;
3046
3047 s = gfc_get_gsymbol(gfc_new_block->name);
3048
3049 if (s->defined
3050 || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3051 global_used(s, NULL);
3052 else
3053 {
3054 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3055 s->where = gfc_current_locus;
3056 s->defined = 1;
3057 }
3058 }
3059
3060
3061 /* Add a program to the global symbol table. */
3062
3063 static void
3064 add_global_program (void)
3065 {
3066 gfc_gsymbol *s;
3067
3068 if (gfc_new_block == NULL)
3069 return;
3070 s = gfc_get_gsymbol (gfc_new_block->name);
3071
3072 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3073 global_used(s, NULL);
3074 else
3075 {
3076 s->type = GSYM_PROGRAM;
3077 s->where = gfc_current_locus;
3078 s->defined = 1;
3079 }
3080 }
3081
3082
3083 /* Top level parser. */
3084
3085 try
3086 gfc_parse_file (void)
3087 {
3088 int seen_program, errors_before, errors;
3089 gfc_state_data top, s;
3090 gfc_statement st;
3091 locus prog_locus;
3092
3093 top.state = COMP_NONE;
3094 top.sym = NULL;
3095 top.previous = NULL;
3096 top.head = top.tail = NULL;
3097 top.do_variable = NULL;
3098
3099 gfc_state_stack = &top;
3100
3101 gfc_clear_new_st ();
3102
3103 gfc_statement_label = NULL;
3104
3105 if (setjmp (eof_buf))
3106 return FAILURE; /* Come here on unexpected EOF */
3107
3108 seen_program = 0;
3109
3110 /* Exit early for empty files. */
3111 if (gfc_at_eof ())
3112 goto done;
3113
3114 loop:
3115 gfc_init_2 ();
3116 st = next_statement ();
3117 switch (st)
3118 {
3119 case ST_NONE:
3120 gfc_done_2 ();
3121 goto done;
3122
3123 case ST_PROGRAM:
3124 if (seen_program)
3125 goto duplicate_main;
3126 seen_program = 1;
3127 prog_locus = gfc_current_locus;
3128
3129 push_state (&s, COMP_PROGRAM, gfc_new_block);
3130 main_program_symbol(gfc_current_ns);
3131 accept_statement (st);
3132 add_global_program ();
3133 parse_progunit (ST_NONE);
3134 break;
3135
3136 case ST_SUBROUTINE:
3137 add_global_procedure (1);
3138 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3139 accept_statement (st);
3140 parse_progunit (ST_NONE);
3141 break;
3142
3143 case ST_FUNCTION:
3144 add_global_procedure (0);
3145 push_state (&s, COMP_FUNCTION, gfc_new_block);
3146 accept_statement (st);
3147 parse_progunit (ST_NONE);
3148 break;
3149
3150 case ST_BLOCK_DATA:
3151 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3152 accept_statement (st);
3153 parse_block_data ();
3154 break;
3155
3156 case ST_MODULE:
3157 push_state (&s, COMP_MODULE, gfc_new_block);
3158 accept_statement (st);
3159
3160 gfc_get_errors (NULL, &errors_before);
3161 parse_module ();
3162 break;
3163
3164 /* Anything else starts a nameless main program block. */
3165 default:
3166 if (seen_program)
3167 goto duplicate_main;
3168 seen_program = 1;
3169 prog_locus = gfc_current_locus;
3170
3171 push_state (&s, COMP_PROGRAM, gfc_new_block);
3172 main_program_symbol(gfc_current_ns);
3173 parse_progunit (st);
3174 break;
3175 }
3176
3177 gfc_current_ns->code = s.head;
3178
3179 gfc_resolve (gfc_current_ns);
3180
3181 /* Dump the parse tree if requested. */
3182 if (gfc_option.verbose)
3183 gfc_show_namespace (gfc_current_ns);
3184
3185 gfc_get_errors (NULL, &errors);
3186 if (s.state == COMP_MODULE)
3187 {
3188 gfc_dump_module (s.sym->name, errors_before == errors);
3189 if (errors == 0 && ! gfc_option.flag_no_backend)
3190 gfc_generate_module_code (gfc_current_ns);
3191 }
3192 else
3193 {
3194 if (errors == 0 && ! gfc_option.flag_no_backend)
3195 gfc_generate_code (gfc_current_ns);
3196 }
3197
3198 pop_state ();
3199 gfc_done_2 ();
3200 goto loop;
3201
3202 done:
3203 return SUCCESS;
3204
3205 duplicate_main:
3206 /* If we see a duplicate main program, shut down. If the second
3207 instance is an implied main program, ie data decls or executable
3208 statements, we're in for lots of errors. */
3209 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3210 reject_statement ();
3211 gfc_done_2 ();
3212 return SUCCESS;
3213 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org