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