?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2008-05-30 Vladimir Makarov <vmakarov@redhat.com>
[official-gcc.git] / gcc / fortran / parse.c
blobb7e63919e8ecb78ca829a18dfc8033c2833fef1a
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 if (current_interface.type != INTERFACE_ABSTRACT &&
1921 !gfc_new_block->attr.dummy &&
1922 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
1923 {
1924 reject_statement ();
1925 gfc_free_namespace (gfc_current_ns);
1926 goto loop;
1927 }
1928 break;
1929
1930 case ST_FUNCTION:
1931 new_state = COMP_FUNCTION;
1932 gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1933 gfc_new_block->formal, NULL);
1934 if (current_interface.type != INTERFACE_ABSTRACT &&
1935 !gfc_new_block->attr.dummy &&
1936 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
1937 {
1938 reject_statement ();
1939 gfc_free_namespace (gfc_current_ns);
1940 goto loop;
1941 }
1942 break;
1943
1944 case ST_PROCEDURE:
1945 case ST_MODULE_PROC: /* The module procedure matcher makes
1946 sure the context is correct. */
1947 accept_statement (st);
1948 gfc_free_namespace (gfc_current_ns);
1949 goto loop;
1950
1951 case ST_END_INTERFACE:
1952 gfc_free_namespace (gfc_current_ns);
1953 gfc_current_ns = current_interface.ns;
1954 goto done;
1955
1956 default:
1957 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1958 gfc_ascii_statement (st));
1959 reject_statement ();
1960 gfc_free_namespace (gfc_current_ns);
1961 goto loop;
1962 }
1963
1964
1965 /* Make sure that a generic interface has only subroutines or
1966 functions and that the generic name has the right attribute. */
1967 if (current_interface.type == INTERFACE_GENERIC)
1968 {
1969 if (current_state == COMP_NONE)
1970 {
1971 if (new_state == COMP_FUNCTION)
1972 gfc_add_function (&sym->attr, sym->name, NULL);
1973 else if (new_state == COMP_SUBROUTINE)
1974 gfc_add_subroutine (&sym->attr, sym->name, NULL);
1975
1976 current_state = new_state;
1977 }
1978 else
1979 {
1980 if (new_state != current_state)
1981 {
1982 if (new_state == COMP_SUBROUTINE)
1983 gfc_error ("SUBROUTINE at %C does not belong in a "
1984 "generic function interface");
1985
1986 if (new_state == COMP_FUNCTION)
1987 gfc_error ("FUNCTION at %C does not belong in a "
1988 "generic subroutine interface");
1989 }
1990 }
1991 }
1992
1993 if (current_interface.type == INTERFACE_ABSTRACT)
1994 {
1995 gfc_new_block->attr.abstract = 1;
1996 if (gfc_is_intrinsic_typename (gfc_new_block->name))
1997 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1998 "cannot be the same as an intrinsic type",
1999 gfc_new_block->name);
2000 }
2001
2002 push_state (&s2, new_state, gfc_new_block);
2003 accept_statement (st);
2004 prog_unit = gfc_new_block;
2005 prog_unit->formal_ns = gfc_current_ns;
2006 proc_locus = gfc_current_locus;
2007
2008 decl:
2009 /* Read data declaration statements. */
2010 st = parse_spec (ST_NONE);
2011
2012 /* Since the interface block does not permit an IMPLICIT statement,
2013 the default type for the function or the result must be taken
2014 from the formal namespace. */
2015 if (new_state == COMP_FUNCTION)
2016 {
2017 if (prog_unit->result == prog_unit
2018 && prog_unit->ts.type == BT_UNKNOWN)
2019 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2020 else if (prog_unit->result != prog_unit
2021 && prog_unit->result->ts.type == BT_UNKNOWN)
2022 gfc_set_default_type (prog_unit->result, 1,
2023 prog_unit->formal_ns);
2024 }
2025
2026 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2027 {
2028 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2029 gfc_ascii_statement (st));
2030 reject_statement ();
2031 goto decl;
2032 }
2033
2034 current_interface = save;
2035 gfc_add_interface (prog_unit);
2036 pop_state ();
2037
2038 if (current_interface.ns
2039 && current_interface.ns->proc_name
2040 && strcmp (current_interface.ns->proc_name->name,
2041 prog_unit->name) == 0)
2042 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2043 "enclosing procedure", prog_unit->name, &proc_locus);
2044
2045 goto loop;
2046
2047 done:
2048 pop_state ();
2049 }
2050
2051
2052 /* Associate function characteristics by going back to the function
2053 declaration and rematching the prefix. */
2054
2055 static match
2056 match_deferred_characteristics (gfc_typespec * ts)
2057 {
2058 locus loc;
2059 match m = MATCH_ERROR;
2060 char name[GFC_MAX_SYMBOL_LEN + 1];
2061
2062 loc = gfc_current_locus;
2063
2064 gfc_current_locus = gfc_current_block ()->declared_at;
2065
2066 gfc_clear_error ();
2067 gfc_buffer_error (1);
2068 m = gfc_match_prefix (ts);
2069 gfc_buffer_error (0);
2070
2071 if (ts->type == BT_DERIVED)
2072 {
2073 ts->kind = 0;
2074
2075 if (!ts->derived || !ts->derived->components)
2076 m = MATCH_ERROR;
2077 }
2078
2079 /* Only permit one go at the characteristic association. */
2080 if (ts->kind == -1)
2081 ts->kind = 0;
2082
2083 /* Set the function locus correctly. If we have not found the
2084 function name, there is an error. */
2085 gfc_match ("function% %n", name);
2086 if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2087 {
2088 gfc_current_block ()->declared_at = gfc_current_locus;
2089 gfc_commit_symbols ();
2090 }
2091 else
2092 gfc_error_check ();
2093
2094 gfc_current_locus =loc;
2095 return m;
2096 }
2097
2098
2099 /* Parse a set of specification statements. Returns the statement
2100 that doesn't fit. */
2101
2102 static gfc_statement
2103 parse_spec (gfc_statement st)
2104 {
2105 st_state ss;
2106 bool bad_characteristic = false;
2107 gfc_typespec *ts;
2108
2109 verify_st_order (&ss, ST_NONE);
2110 if (st == ST_NONE)
2111 st = next_statement ();
2112
2113 loop:
2114 switch (st)
2115 {
2116 case ST_NONE:
2117 unexpected_eof ();
2118
2119 case ST_FORMAT:
2120 case ST_ENTRY:
2121 case ST_DATA: /* Not allowed in interfaces */
2122 if (gfc_current_state () == COMP_INTERFACE)
2123 break;
2124
2125 /* Fall through */
2126
2127 case ST_USE:
2128 case ST_IMPORT:
2129 case ST_IMPLICIT_NONE:
2130 case ST_IMPLICIT:
2131 case ST_PARAMETER:
2132 case ST_PUBLIC:
2133 case ST_PRIVATE:
2134 case ST_DERIVED_DECL:
2135 case_decl:
2136 if (verify_st_order (&ss, st) == FAILURE)
2137 {
2138 reject_statement ();
2139 st = next_statement ();
2140 goto loop;
2141 }
2142
2143 switch (st)
2144 {
2145 case ST_INTERFACE:
2146 parse_interface ();
2147 break;
2148
2149 case ST_DERIVED_DECL:
2150 parse_derived ();
2151 break;
2152
2153 case ST_PUBLIC:
2154 case ST_PRIVATE:
2155 if (gfc_current_state () != COMP_MODULE)
2156 {
2157 gfc_error ("%s statement must appear in a MODULE",
2158 gfc_ascii_statement (st));
2159 break;
2160 }
2161
2162 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2163 {
2164 gfc_error ("%s statement at %C follows another accessibility "
2165 "specification", gfc_ascii_statement (st));
2166 break;
2167 }
2168
2169 gfc_current_ns->default_access = (st == ST_PUBLIC)
2170 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2171
2172 break;
2173
2174 case ST_STATEMENT_FUNCTION:
2175 if (gfc_current_state () == COMP_MODULE)
2176 {
2177 unexpected_statement (st);
2178 break;
2179 }
2180
2181 default:
2182 break;
2183 }
2184
2185 accept_statement (st);
2186 st = next_statement ();
2187 goto loop;
2188
2189 case ST_ENUM:
2190 accept_statement (st);
2191 parse_enum();
2192 st = next_statement ();
2193 goto loop;
2194
2195 case ST_GET_FCN_CHARACTERISTICS:
2196 /* This statement triggers the association of a function's result
2197 characteristics. */
2198 ts = &gfc_current_block ()->result->ts;
2199 if (match_deferred_characteristics (ts) != MATCH_YES)
2200 bad_characteristic = true;
2201
2202 st = next_statement ();
2203 goto loop;
2204
2205 default:
2206 break;
2207 }
2208
2209 /* If match_deferred_characteristics failed, then there is an error. */
2210 if (bad_characteristic)
2211 {
2212 ts = &gfc_current_block ()->result->ts;
2213 if (ts->type != BT_DERIVED)
2214 gfc_error ("Bad kind expression for function '%s' at %L",
2215 gfc_current_block ()->name,
2216 &gfc_current_block ()->declared_at);
2217 else
2218 gfc_error ("The type for function '%s' at %L is not accessible",
2219 gfc_current_block ()->name,
2220 &gfc_current_block ()->declared_at);
2221
2222 gfc_current_block ()->ts.kind = 0;
2223 /* Keep the derived type; if it's bad, it will be discovered later. */
2224 if (!(ts->type == BT_DERIVED && ts->derived))
2225 ts->type = BT_UNKNOWN;
2226 }
2227
2228 return st;
2229 }
2230
2231
2232 /* Parse a WHERE block, (not a simple WHERE statement). */
2233
2234 static void
2235 parse_where_block (void)
2236 {
2237 int seen_empty_else;
2238 gfc_code *top, *d;
2239 gfc_state_data s;
2240 gfc_statement st;
2241
2242 accept_statement (ST_WHERE_BLOCK);
2243 top = gfc_state_stack->tail;
2244
2245 push_state (&s, COMP_WHERE, gfc_new_block);
2246
2247 d = add_statement ();
2248 d->expr = top->expr;
2249 d->op = EXEC_WHERE;
2250
2251 top->expr = NULL;
2252 top->block = d;
2253
2254 seen_empty_else = 0;
2255
2256 do
2257 {
2258 st = next_statement ();
2259 switch (st)
2260 {
2261 case ST_NONE:
2262 unexpected_eof ();
2263
2264 case ST_WHERE_BLOCK:
2265 parse_where_block ();
2266 break;
2267
2268 case ST_ASSIGNMENT:
2269 case ST_WHERE:
2270 accept_statement (st);
2271 break;
2272
2273 case ST_ELSEWHERE:
2274 if (seen_empty_else)
2275 {
2276 gfc_error ("ELSEWHERE statement at %C follows previous "
2277 "unmasked ELSEWHERE");
2278 break;
2279 }
2280
2281 if (new_st.expr == NULL)
2282 seen_empty_else = 1;
2283
2284 d = new_level (gfc_state_stack->head);
2285 d->op = EXEC_WHERE;
2286 d->expr = new_st.expr;
2287
2288 accept_statement (st);
2289
2290 break;
2291
2292 case ST_END_WHERE:
2293 accept_statement (st);
2294 break;
2295
2296 default:
2297 gfc_error ("Unexpected %s statement in WHERE block at %C",
2298 gfc_ascii_statement (st));
2299 reject_statement ();
2300 break;
2301 }
2302 }
2303 while (st != ST_END_WHERE);
2304
2305 pop_state ();
2306 }
2307
2308
2309 /* Parse a FORALL block (not a simple FORALL statement). */
2310
2311 static void
2312 parse_forall_block (void)
2313 {
2314 gfc_code *top, *d;
2315 gfc_state_data s;
2316 gfc_statement st;
2317
2318 accept_statement (ST_FORALL_BLOCK);
2319 top = gfc_state_stack->tail;
2320
2321 push_state (&s, COMP_FORALL, gfc_new_block);
2322
2323 d = add_statement ();
2324 d->op = EXEC_FORALL;
2325 top->block = d;
2326
2327 do
2328 {
2329 st = next_statement ();
2330 switch (st)
2331 {
2332
2333 case ST_ASSIGNMENT:
2334 case ST_POINTER_ASSIGNMENT:
2335 case ST_WHERE:
2336 case ST_FORALL:
2337 accept_statement (st);
2338 break;
2339
2340 case ST_WHERE_BLOCK:
2341 parse_where_block ();
2342 break;
2343
2344 case ST_FORALL_BLOCK:
2345 parse_forall_block ();
2346 break;
2347
2348 case ST_END_FORALL:
2349 accept_statement (st);
2350 break;
2351
2352 case ST_NONE:
2353 unexpected_eof ();
2354
2355 default:
2356 gfc_error ("Unexpected %s statement in FORALL block at %C",
2357 gfc_ascii_statement (st));
2358
2359 reject_statement ();
2360 break;
2361 }
2362 }
2363 while (st != ST_END_FORALL);
2364
2365 pop_state ();
2366 }
2367
2368
2369 static gfc_statement parse_executable (gfc_statement);
2370
2371 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2372
2373 static void
2374 parse_if_block (void)
2375 {
2376 gfc_code *top, *d;
2377 gfc_statement st;
2378 locus else_locus;
2379 gfc_state_data s;
2380 int seen_else;
2381
2382 seen_else = 0;
2383 accept_statement (ST_IF_BLOCK);
2384
2385 top = gfc_state_stack->tail;
2386 push_state (&s, COMP_IF, gfc_new_block);
2387
2388 new_st.op = EXEC_IF;
2389 d = add_statement ();
2390
2391 d->expr = top->expr;
2392 top->expr = NULL;
2393 top->block = d;
2394
2395 do
2396 {
2397 st = parse_executable (ST_NONE);
2398
2399 switch (st)
2400 {
2401 case ST_NONE:
2402 unexpected_eof ();
2403
2404 case ST_ELSEIF:
2405 if (seen_else)
2406 {
2407 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2408 "statement at %L", &else_locus);
2409
2410 reject_statement ();
2411 break;
2412 }
2413
2414 d = new_level (gfc_state_stack->head);
2415 d->op = EXEC_IF;
2416 d->expr = new_st.expr;
2417
2418 accept_statement (st);
2419
2420 break;
2421
2422 case ST_ELSE:
2423 if (seen_else)
2424 {
2425 gfc_error ("Duplicate ELSE statements at %L and %C",
2426 &else_locus);
2427 reject_statement ();
2428 break;
2429 }
2430
2431 seen_else = 1;
2432 else_locus = gfc_current_locus;
2433
2434 d = new_level (gfc_state_stack->head);
2435 d->op = EXEC_IF;
2436
2437 accept_statement (st);
2438
2439 break;
2440
2441 case ST_ENDIF:
2442 break;
2443
2444 default:
2445 unexpected_statement (st);
2446 break;
2447 }
2448 }
2449 while (st != ST_ENDIF);
2450
2451 pop_state ();
2452 accept_statement (st);
2453 }
2454
2455
2456 /* Parse a SELECT block. */
2457
2458 static void
2459 parse_select_block (void)
2460 {
2461 gfc_statement st;
2462 gfc_code *cp;
2463 gfc_state_data s;
2464
2465 accept_statement (ST_SELECT_CASE);
2466
2467 cp = gfc_state_stack->tail;
2468 push_state (&s, COMP_SELECT, gfc_new_block);
2469
2470 /* Make sure that the next statement is a CASE or END SELECT. */
2471 for (;;)
2472 {
2473 st = next_statement ();
2474 if (st == ST_NONE)
2475 unexpected_eof ();
2476 if (st == ST_END_SELECT)
2477 {
2478 /* Empty SELECT CASE is OK. */
2479 accept_statement (st);
2480 pop_state ();
2481 return;
2482 }
2483 if (st == ST_CASE)
2484 break;
2485
2486 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2487 "CASE at %C");
2488
2489 reject_statement ();
2490 }
2491
2492 /* At this point, we're got a nonempty select block. */
2493 cp = new_level (cp);
2494 *cp = new_st;
2495
2496 accept_statement (st);
2497
2498 do
2499 {
2500 st = parse_executable (ST_NONE);
2501 switch (st)
2502 {
2503 case ST_NONE:
2504 unexpected_eof ();
2505
2506 case ST_CASE:
2507 cp = new_level (gfc_state_stack->head);
2508 *cp = new_st;
2509 gfc_clear_new_st ();
2510
2511 accept_statement (st);
2512 /* Fall through */
2513
2514 case ST_END_SELECT:
2515 break;
2516
2517 /* Can't have an executable statement because of
2518 parse_executable(). */
2519 default:
2520 unexpected_statement (st);
2521 break;
2522 }
2523 }
2524 while (st != ST_END_SELECT);
2525
2526 pop_state ();
2527 accept_statement (st);
2528 }
2529
2530
2531 /* Given a symbol, make sure it is not an iteration variable for a DO
2532 statement. This subroutine is called when the symbol is seen in a
2533 context that causes it to become redefined. If the symbol is an
2534 iterator, we generate an error message and return nonzero. */
2535
2536 int
2537 gfc_check_do_variable (gfc_symtree *st)
2538 {
2539 gfc_state_data *s;
2540
2541 for (s=gfc_state_stack; s; s = s->previous)
2542 if (s->do_variable == st)
2543 {
2544 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2545 "loop beginning at %L", st->name, &s->head->loc);
2546 return 1;
2547 }
2548
2549 return 0;
2550 }
2551
2552
2553 /* Checks to see if the current statement label closes an enddo.
2554 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2555 an error) if it incorrectly closes an ENDDO. */
2556
2557 static int
2558 check_do_closure (void)
2559 {
2560 gfc_state_data *p;
2561
2562 if (gfc_statement_label == NULL)
2563 return 0;
2564
2565 for (p = gfc_state_stack; p; p = p->previous)
2566 if (p->state == COMP_DO)
2567 break;
2568
2569 if (p == NULL)
2570 return 0; /* No loops to close */
2571
2572 if (p->ext.end_do_label == gfc_statement_label)
2573 {
2574
2575 if (p == gfc_state_stack)
2576 return 1;
2577
2578 gfc_error ("End of nonblock DO statement at %C is within another block");
2579 return 2;
2580 }
2581
2582 /* At this point, the label doesn't terminate the innermost loop.
2583 Make sure it doesn't terminate another one. */
2584 for (; p; p = p->previous)
2585 if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2586 {
2587 gfc_error ("End of nonblock DO statement at %C is interwoven "
2588 "with another DO loop");
2589 return 2;
2590 }
2591
2592 return 0;
2593 }
2594
2595
2596 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2597 handled inside of parse_executable(), because they aren't really
2598 loop statements. */
2599
2600 static void
2601 parse_do_block (void)
2602 {
2603 gfc_statement st;
2604 gfc_code *top;
2605 gfc_state_data s;
2606 gfc_symtree *stree;
2607
2608 s.ext.end_do_label = new_st.label;
2609
2610 if (new_st.ext.iterator != NULL)
2611 stree = new_st.ext.iterator->var->symtree;
2612 else
2613 stree = NULL;
2614
2615 accept_statement (ST_DO);
2616
2617 top = gfc_state_stack->tail;
2618 push_state (&s, COMP_DO, gfc_new_block);
2619
2620 s.do_variable = stree;
2621
2622 top->block = new_level (top);
2623 top->block->op = EXEC_DO;
2624
2625 loop:
2626 st = parse_executable (ST_NONE);
2627
2628 switch (st)
2629 {
2630 case ST_NONE:
2631 unexpected_eof ();
2632
2633 case ST_ENDDO:
2634 if (s.ext.end_do_label != NULL
2635 && s.ext.end_do_label != gfc_statement_label)
2636 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2637 "DO label");
2638
2639 if (gfc_statement_label != NULL)
2640 {
2641 new_st.op = EXEC_NOP;
2642 add_statement ();
2643 }
2644 break;
2645
2646 case ST_IMPLIED_ENDDO:
2647 /* If the do-stmt of this DO construct has a do-construct-name,
2648 the corresponding end-do must be an end-do-stmt (with a matching
2649 name, but in that case we must have seen ST_ENDDO first).
2650 We only complain about this in pedantic mode. */
2651 if (gfc_current_block () != NULL)
2652 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2653 &gfc_current_block()->declared_at);
2654
2655 break;
2656
2657 default:
2658 unexpected_statement (st);
2659 goto loop;
2660 }
2661
2662 pop_state ();
2663 accept_statement (st);
2664 }
2665
2666
2667 /* Parse the statements of OpenMP do/parallel do. */
2668
2669 static gfc_statement
2670 parse_omp_do (gfc_statement omp_st)
2671 {
2672 gfc_statement st;
2673 gfc_code *cp, *np;
2674 gfc_state_data s;
2675
2676 accept_statement (omp_st);
2677
2678 cp = gfc_state_stack->tail;
2679 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2680 np = new_level (cp);
2681 np->op = cp->op;
2682 np->block = NULL;
2683
2684 for (;;)
2685 {
2686 st = next_statement ();
2687 if (st == ST_NONE)
2688 unexpected_eof ();
2689 else if (st == ST_DO)
2690 break;
2691 else
2692 unexpected_statement (st);
2693 }
2694
2695 parse_do_block ();
2696 if (gfc_statement_label != NULL
2697 && gfc_state_stack->previous != NULL
2698 && gfc_state_stack->previous->state == COMP_DO
2699 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2700 {
2701 /* In
2702 DO 100 I=1,10
2703 !$OMP DO
2704 DO J=1,10
2705 ...
2706 100 CONTINUE
2707 there should be no !$OMP END DO. */
2708 pop_state ();
2709 return ST_IMPLIED_ENDDO;
2710 }
2711
2712 check_do_closure ();
2713 pop_state ();
2714
2715 st = next_statement ();
2716 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2717 {
2718 if (new_st.op == EXEC_OMP_END_NOWAIT)
2719 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2720 else
2721 gcc_assert (new_st.op == EXEC_NOP);
2722 gfc_clear_new_st ();
2723 gfc_commit_symbols ();
2724 gfc_warning_check ();
2725 st = next_statement ();
2726 }
2727 return st;
2728 }
2729
2730
2731 /* Parse the statements of OpenMP atomic directive. */
2732
2733 static void
2734 parse_omp_atomic (void)
2735 {
2736 gfc_statement st;
2737 gfc_code *cp, *np;
2738 gfc_state_data s;
2739
2740 accept_statement (ST_OMP_ATOMIC);
2741
2742 cp = gfc_state_stack->tail;
2743 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2744 np = new_level (cp);
2745 np->op = cp->op;
2746 np->block = NULL;
2747
2748 for (;;)
2749 {
2750 st = next_statement ();
2751 if (st == ST_NONE)
2752 unexpected_eof ();
2753 else if (st == ST_ASSIGNMENT)
2754 break;
2755 else
2756 unexpected_statement (st);
2757 }
2758
2759 accept_statement (st);
2760
2761 pop_state ();
2762 }
2763
2764
2765 /* Parse the statements of an OpenMP structured block. */
2766
2767 static void
2768 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2769 {
2770 gfc_statement st, omp_end_st;
2771 gfc_code *cp, *np;
2772 gfc_state_data s;
2773
2774 accept_statement (omp_st);
2775
2776 cp = gfc_state_stack->tail;
2777 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2778 np = new_level (cp);
2779 np->op = cp->op;
2780 np->block = NULL;
2781
2782 switch (omp_st)
2783 {
2784 case ST_OMP_PARALLEL:
2785 omp_end_st = ST_OMP_END_PARALLEL;
2786 break;
2787 case ST_OMP_PARALLEL_SECTIONS:
2788 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2789 break;
2790 case ST_OMP_SECTIONS:
2791 omp_end_st = ST_OMP_END_SECTIONS;
2792 break;
2793 case ST_OMP_ORDERED:
2794 omp_end_st = ST_OMP_END_ORDERED;
2795 break;
2796 case ST_OMP_CRITICAL:
2797 omp_end_st = ST_OMP_END_CRITICAL;
2798 break;
2799 case ST_OMP_MASTER:
2800 omp_end_st = ST_OMP_END_MASTER;
2801 break;
2802 case ST_OMP_SINGLE:
2803 omp_end_st = ST_OMP_END_SINGLE;
2804 break;
2805 case ST_OMP_WORKSHARE:
2806 omp_end_st = ST_OMP_END_WORKSHARE;
2807 break;
2808 case ST_OMP_PARALLEL_WORKSHARE:
2809 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2810 break;
2811 default:
2812 gcc_unreachable ();
2813 }
2814
2815 do
2816 {
2817 if (workshare_stmts_only)
2818 {
2819 /* Inside of !$omp workshare, only
2820 scalar assignments
2821 array assignments
2822 where statements and constructs
2823 forall statements and constructs
2824 !$omp atomic
2825 !$omp critical
2826 !$omp parallel
2827 are allowed. For !$omp critical these
2828 restrictions apply recursively. */
2829 bool cycle = true;
2830
2831 st = next_statement ();
2832 for (;;)
2833 {
2834 switch (st)
2835 {
2836 case ST_NONE:
2837 unexpected_eof ();
2838
2839 case ST_ASSIGNMENT:
2840 case ST_WHERE:
2841 case ST_FORALL:
2842 accept_statement (st);
2843 break;
2844
2845 case ST_WHERE_BLOCK:
2846 parse_where_block ();
2847 break;
2848
2849 case ST_FORALL_BLOCK:
2850 parse_forall_block ();
2851 break;
2852
2853 case ST_OMP_PARALLEL:
2854 case ST_OMP_PARALLEL_SECTIONS:
2855 parse_omp_structured_block (st, false);
2856 break;
2857
2858 case ST_OMP_PARALLEL_WORKSHARE:
2859 case ST_OMP_CRITICAL:
2860 parse_omp_structured_block (st, true);
2861 break;
2862
2863 case ST_OMP_PARALLEL_DO:
2864 st = parse_omp_do (st);
2865 continue;
2866
2867 case ST_OMP_ATOMIC:
2868 parse_omp_atomic ();
2869 break;
2870
2871 default:
2872 cycle = false;
2873 break;
2874 }
2875
2876 if (!cycle)
2877 break;
2878
2879 st = next_statement ();
2880 }
2881 }
2882 else
2883 st = parse_executable (ST_NONE);
2884 if (st == ST_NONE)
2885 unexpected_eof ();
2886 else if (st == ST_OMP_SECTION
2887 && (omp_st == ST_OMP_SECTIONS
2888 || omp_st == ST_OMP_PARALLEL_SECTIONS))
2889 {
2890 np = new_level (np);
2891 np->op = cp->op;
2892 np->block = NULL;
2893 }
2894 else if (st != omp_end_st)
2895 unexpected_statement (st);
2896 }
2897 while (st != omp_end_st);
2898
2899 switch (new_st.op)
2900 {
2901 case EXEC_OMP_END_NOWAIT:
2902 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2903 break;
2904 case EXEC_OMP_CRITICAL:
2905 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2906 || (new_st.ext.omp_name != NULL
2907 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2908 gfc_error ("Name after !$omp critical and !$omp end critical does "
2909 "not match at %C");
2910 gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2911 break;
2912 case EXEC_OMP_END_SINGLE:
2913 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2914 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2915 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2916 gfc_free_omp_clauses (new_st.ext.omp_clauses);
2917 break;
2918 case EXEC_NOP:
2919 break;
2920 default:
2921 gcc_unreachable ();
2922 }
2923
2924 gfc_clear_new_st ();
2925 gfc_commit_symbols ();
2926 gfc_warning_check ();
2927 pop_state ();
2928 }
2929
2930
2931 /* Accept a series of executable statements. We return the first
2932 statement that doesn't fit to the caller. Any block statements are
2933 passed on to the correct handler, which usually passes the buck
2934 right back here. */
2935
2936 static gfc_statement
2937 parse_executable (gfc_statement st)
2938 {
2939 int close_flag;
2940
2941 if (st == ST_NONE)
2942 st = next_statement ();
2943
2944 for (;;)
2945 {
2946 close_flag = check_do_closure ();
2947 if (close_flag)
2948 switch (st)
2949 {
2950 case ST_GOTO:
2951 case ST_END_PROGRAM:
2952 case ST_RETURN:
2953 case ST_EXIT:
2954 case ST_END_FUNCTION:
2955 case ST_CYCLE:
2956 case ST_PAUSE:
2957 case ST_STOP:
2958 case ST_END_SUBROUTINE:
2959
2960 case ST_DO:
2961 case ST_FORALL:
2962 case ST_WHERE:
2963 case ST_SELECT_CASE:
2964 gfc_error ("%s statement at %C cannot terminate a non-block "
2965 "DO loop", gfc_ascii_statement (st));
2966 break;
2967
2968 default:
2969 break;
2970 }
2971
2972 switch (st)
2973 {
2974 case ST_NONE:
2975 unexpected_eof ();
2976
2977 case ST_FORMAT:
2978 case ST_DATA:
2979 case ST_ENTRY:
2980 case_executable:
2981 accept_statement (st);
2982 if (close_flag == 1)
2983 return ST_IMPLIED_ENDDO;
2984 break;
2985
2986 case ST_IF_BLOCK:
2987 parse_if_block ();
2988 break;
2989
2990 case ST_SELECT_CASE:
2991 parse_select_block ();
2992 break;
2993
2994 case ST_DO:
2995 parse_do_block ();
2996 if (check_do_closure () == 1)
2997 return ST_IMPLIED_ENDDO;
2998 break;
2999
3000 case ST_WHERE_BLOCK:
3001 parse_where_block ();
3002 break;
3003
3004 case ST_FORALL_BLOCK:
3005 parse_forall_block ();
3006 break;
3007
3008 case ST_OMP_PARALLEL:
3009 case ST_OMP_PARALLEL_SECTIONS:
3010 case ST_OMP_SECTIONS:
3011 case ST_OMP_ORDERED:
3012 case ST_OMP_CRITICAL:
3013 case ST_OMP_MASTER:
3014 case ST_OMP_SINGLE:
3015 parse_omp_structured_block (st, false);
3016 break;
3017
3018 case ST_OMP_WORKSHARE:
3019 case ST_OMP_PARALLEL_WORKSHARE:
3020 parse_omp_structured_block (st, true);
3021 break;
3022
3023 case ST_OMP_DO:
3024 case ST_OMP_PARALLEL_DO:
3025 st = parse_omp_do (st);
3026 if (st == ST_IMPLIED_ENDDO)
3027 return st;
3028 continue;
3029
3030 case ST_OMP_ATOMIC:
3031 parse_omp_atomic ();
3032 break;
3033
3034 default:
3035 return st;
3036 }
3037
3038 st = next_statement ();
3039 }
3040 }
3041
3042
3043 /* Parse a series of contained program units. */
3044
3045 static void parse_progunit (gfc_statement);
3046
3047
3048 /* Fix the symbols for sibling functions. These are incorrectly added to
3049 the child namespace as the parser didn't know about this procedure. */
3050
3051 static void
3052 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3053 {
3054 gfc_namespace *ns;
3055 gfc_symtree *st;
3056 gfc_symbol *old_sym;
3057
3058 sym->attr.referenced = 1;
3059 for (ns = siblings; ns; ns = ns->sibling)
3060 {
3061 gfc_find_sym_tree (sym->name, ns, 0, &st);
3062
3063 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3064 continue;
3065
3066 old_sym = st->n.sym;
3067 if (old_sym->ns == ns
3068 && !old_sym->attr.contained
3069
3070 /* By 14.6.1.3, host association should be excluded
3071 for the following. */
3072 && !(old_sym->attr.external
3073 || (old_sym->ts.type != BT_UNKNOWN
3074 && !old_sym->attr.implicit_type)
3075 || old_sym->attr.flavor == FL_PARAMETER
3076 || old_sym->attr.in_common
3077 || old_sym->attr.in_equivalence
3078 || old_sym->attr.data
3079 || old_sym->attr.dummy
3080 || old_sym->attr.result
3081 || old_sym->attr.dimension
3082 || old_sym->attr.allocatable
3083 || old_sym->attr.intrinsic
3084 || old_sym->attr.generic
3085 || old_sym->attr.flavor == FL_NAMELIST
3086 || old_sym->attr.proc == PROC_ST_FUNCTION))
3087 {
3088 /* Replace it with the symbol from the parent namespace. */
3089 st->n.sym = sym;
3090 sym->refs++;
3091
3092 /* Free the old (local) symbol. */
3093 old_sym->refs--;
3094 if (old_sym->refs == 0)
3095 gfc_free_symbol (old_sym);
3096 }
3097
3098 /* Do the same for any contained procedures. */
3099 gfc_fixup_sibling_symbols (sym, ns->contained);
3100 }
3101 }
3102
3103 static void
3104 parse_contained (int module)
3105 {
3106 gfc_namespace *ns, *parent_ns, *tmp;
3107 gfc_state_data s1, s2;
3108 gfc_statement st;
3109 gfc_symbol *sym;
3110 gfc_entry_list *el;
3111 int contains_statements = 0;
3112 int seen_error = 0;
3113
3114 push_state (&s1, COMP_CONTAINS, NULL);
3115 parent_ns = gfc_current_ns;
3116
3117 do
3118 {
3119 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3120
3121 gfc_current_ns->sibling = parent_ns->contained;
3122 parent_ns->contained = gfc_current_ns;
3123
3124 next:
3125 /* Process the next available statement. We come here if we got an error
3126 and rejected the last statement. */
3127 st = next_statement ();
3128
3129 switch (st)
3130 {
3131 case ST_NONE:
3132 unexpected_eof ();
3133
3134 case ST_FUNCTION:
3135 case ST_SUBROUTINE:
3136 contains_statements = 1;
3137 accept_statement (st);
3138
3139 push_state (&s2,
3140 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3141 gfc_new_block);
3142
3143 /* For internal procedures, create/update the symbol in the
3144 parent namespace. */
3145
3146 if (!module)
3147 {
3148 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3149 gfc_error ("Contained procedure '%s' at %C is already "
3150 "ambiguous", gfc_new_block->name);
3151 else
3152 {
3153 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3154 &gfc_new_block->declared_at) ==
3155 SUCCESS)
3156 {
3157 if (st == ST_FUNCTION)
3158 gfc_add_function (&sym->attr, sym->name,
3159 &gfc_new_block->declared_at);
3160 else
3161 gfc_add_subroutine (&sym->attr, sym->name,
3162 &gfc_new_block->declared_at);
3163 }
3164 }
3165
3166 gfc_commit_symbols ();
3167 }
3168 else
3169 sym = gfc_new_block;
3170
3171 /* Mark this as a contained function, so it isn't replaced
3172 by other module functions. */
3173 sym->attr.contained = 1;
3174 sym->attr.referenced = 1;
3175
3176 parse_progunit (ST_NONE);
3177
3178 /* Fix up any sibling functions that refer to this one. */
3179 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3180 /* Or refer to any of its alternate entry points. */
3181 for (el = gfc_current_ns->entries; el; el = el->next)
3182 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3183
3184 gfc_current_ns->code = s2.head;
3185 gfc_current_ns = parent_ns;
3186
3187 pop_state ();
3188 break;
3189
3190 /* These statements are associated with the end of the host unit. */
3191 case ST_END_FUNCTION:
3192 case ST_END_MODULE:
3193 case ST_END_PROGRAM:
3194 case ST_END_SUBROUTINE:
3195 accept_statement (st);
3196 break;
3197
3198 default:
3199 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3200 gfc_ascii_statement (st));
3201 reject_statement ();
3202 seen_error = 1;
3203 goto next;
3204 break;
3205 }
3206 }
3207 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3208 && st != ST_END_MODULE && st != ST_END_PROGRAM);
3209
3210 /* The first namespace in the list is guaranteed to not have
3211 anything (worthwhile) in it. */
3212 tmp = gfc_current_ns;
3213 gfc_current_ns = parent_ns;
3214 if (seen_error && tmp->refs > 1)
3215 gfc_free_namespace (tmp);
3216
3217 ns = gfc_current_ns->contained;
3218 gfc_current_ns->contained = ns->sibling;
3219 gfc_free_namespace (ns);
3220
3221 pop_state ();
3222 if (!contains_statements)
3223 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3224 "FUNCTION or SUBROUTINE statement at %C");
3225 }
3226
3227
3228 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
3229
3230 static void
3231 parse_progunit (gfc_statement st)
3232 {
3233 gfc_state_data *p;
3234 int n;
3235
3236 st = parse_spec (st);
3237 switch (st)
3238 {
3239 case ST_NONE:
3240 unexpected_eof ();
3241
3242 case ST_CONTAINS:
3243 goto contains;
3244
3245 case_end:
3246 accept_statement (st);
3247 goto done;
3248
3249 default:
3250 break;
3251 }
3252
3253 if (gfc_current_state () == COMP_FUNCTION)
3254 gfc_check_function_type (gfc_current_ns);
3255
3256 loop:
3257 for (;;)
3258 {
3259 st = parse_executable (st);
3260
3261 switch (st)
3262 {
3263 case ST_NONE:
3264 unexpected_eof ();
3265
3266 case ST_CONTAINS:
3267 goto contains;
3268
3269 case_end:
3270 accept_statement (st);
3271 goto done;
3272
3273 default:
3274 break;
3275 }
3276
3277 unexpected_statement (st);
3278 reject_statement ();
3279 st = next_statement ();
3280 }
3281
3282 contains:
3283 n = 0;
3284
3285 for (p = gfc_state_stack; p; p = p->previous)
3286 if (p->state == COMP_CONTAINS)
3287 n++;
3288
3289 if (gfc_find_state (COMP_MODULE) == SUCCESS)
3290 n--;
3291
3292 if (n > 0)
3293 {
3294 gfc_error ("CONTAINS statement at %C is already in a contained "
3295 "program unit");
3296 st = next_statement ();
3297 goto loop;
3298 }
3299
3300 parse_contained (0);
3301
3302 done:
3303 gfc_current_ns->code = gfc_state_stack->head;
3304 }
3305
3306
3307 /* Come here to complain about a global symbol already in use as
3308 something else. */
3309
3310 void
3311 gfc_global_used (gfc_gsymbol *sym, locus *where)
3312 {
3313 const char *name;
3314
3315 if (where == NULL)
3316 where = &gfc_current_locus;
3317
3318 switch(sym->type)
3319 {
3320 case GSYM_PROGRAM:
3321 name = "PROGRAM";
3322 break;
3323 case GSYM_FUNCTION:
3324 name = "FUNCTION";
3325 break;
3326 case GSYM_SUBROUTINE:
3327 name = "SUBROUTINE";
3328 break;
3329 case GSYM_COMMON:
3330 name = "COMMON";
3331 break;
3332 case GSYM_BLOCK_DATA:
3333 name = "BLOCK DATA";
3334 break;
3335 case GSYM_MODULE:
3336 name = "MODULE";
3337 break;
3338 default:
3339 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3340 name = NULL;
3341 }
3342
3343 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3344 sym->name, where, name, &sym->where);
3345 }
3346
3347
3348 /* Parse a block data program unit. */
3349
3350 static void
3351 parse_block_data (void)
3352 {
3353 gfc_statement st;
3354 static locus blank_locus;
3355 static int blank_block=0;
3356 gfc_gsymbol *s;
3357
3358 gfc_current_ns->proc_name = gfc_new_block;
3359 gfc_current_ns->is_block_data = 1;
3360
3361 if (gfc_new_block == NULL)
3362 {
3363 if (blank_block)
3364 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3365 "prior BLOCK DATA at %L", &blank_locus);
3366 else
3367 {
3368 blank_block = 1;
3369 blank_locus = gfc_current_locus;
3370 }
3371 }
3372 else
3373 {
3374 s = gfc_get_gsymbol (gfc_new_block->name);
3375 if (s->defined
3376 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3377 gfc_global_used(s, NULL);
3378 else
3379 {
3380 s->type = GSYM_BLOCK_DATA;
3381 s->where = gfc_current_locus;
3382 s->defined = 1;
3383 }
3384 }
3385
3386 st = parse_spec (ST_NONE);
3387
3388 while (st != ST_END_BLOCK_DATA)
3389 {
3390 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3391 gfc_ascii_statement (st));
3392 reject_statement ();
3393 st = next_statement ();
3394 }
3395 }
3396
3397
3398 /* Parse a module subprogram. */
3399
3400 static void
3401 parse_module (void)
3402 {
3403 gfc_statement st;
3404 gfc_gsymbol *s;
3405
3406 s = gfc_get_gsymbol (gfc_new_block->name);
3407 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3408 gfc_global_used(s, NULL);
3409 else
3410 {
3411 s->type = GSYM_MODULE;
3412 s->where = gfc_current_locus;
3413 s->defined = 1;
3414 }
3415
3416 st = parse_spec (ST_NONE);
3417
3418 loop:
3419 switch (st)
3420 {
3421 case ST_NONE:
3422 unexpected_eof ();
3423
3424 case ST_CONTAINS:
3425 parse_contained (1);
3426 break;
3427
3428 case ST_END_MODULE:
3429 accept_statement (st);
3430 break;
3431
3432 default:
3433 gfc_error ("Unexpected %s statement in MODULE at %C",
3434 gfc_ascii_statement (st));
3435
3436 reject_statement ();
3437 st = next_statement ();
3438 goto loop;
3439 }
3440 }
3441
3442
3443 /* Add a procedure name to the global symbol table. */
3444
3445 static void
3446 add_global_procedure (int sub)
3447 {
3448 gfc_gsymbol *s;
3449
3450 s = gfc_get_gsymbol(gfc_new_block->name);
3451
3452 if (s->defined
3453 || (s->type != GSYM_UNKNOWN
3454 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3455 gfc_global_used(s, NULL);
3456 else
3457 {
3458 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3459 s->where = gfc_current_locus;
3460 s->defined = 1;
3461 }
3462 }
3463
3464
3465 /* Add a program to the global symbol table. */
3466
3467 static void
3468 add_global_program (void)
3469 {
3470 gfc_gsymbol *s;
3471
3472 if (gfc_new_block == NULL)
3473 return;
3474 s = gfc_get_gsymbol (gfc_new_block->name);
3475
3476 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3477 gfc_global_used(s, NULL);
3478 else
3479 {
3480 s->type = GSYM_PROGRAM;
3481 s->where = gfc_current_locus;
3482 s->defined = 1;
3483 }
3484 }
3485
3486
3487 /* Top level parser. */
3488
3489 try
3490 gfc_parse_file (void)
3491 {
3492 int seen_program, errors_before, errors;
3493 gfc_state_data top, s;
3494 gfc_statement st;
3495 locus prog_locus;
3496
3497 gfc_start_source_files ();
3498
3499 top.state = COMP_NONE;
3500 top.sym = NULL;
3501 top.previous = NULL;
3502 top.head = top.tail = NULL;
3503 top.do_variable = NULL;
3504
3505 gfc_state_stack = &top;
3506
3507 gfc_clear_new_st ();
3508
3509 gfc_statement_label = NULL;
3510
3511 if (setjmp (eof_buf))
3512 return FAILURE; /* Come here on unexpected EOF */
3513
3514 seen_program = 0;
3515
3516 /* Exit early for empty files. */
3517 if (gfc_at_eof ())
3518 goto done;
3519
3520 loop:
3521 gfc_init_2 ();
3522 st = next_statement ();
3523 switch (st)
3524 {
3525 case ST_NONE:
3526 gfc_done_2 ();
3527 goto done;
3528
3529 case ST_PROGRAM:
3530 if (seen_program)
3531 goto duplicate_main;
3532 seen_program = 1;
3533 prog_locus = gfc_current_locus;
3534
3535 push_state (&s, COMP_PROGRAM, gfc_new_block);
3536 main_program_symbol(gfc_current_ns, gfc_new_block->name);
3537 accept_statement (st);
3538 add_global_program ();
3539 parse_progunit (ST_NONE);
3540 break;
3541
3542 case ST_SUBROUTINE:
3543 add_global_procedure (1);
3544 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3545 accept_statement (st);
3546 parse_progunit (ST_NONE);
3547 break;
3548
3549 case ST_FUNCTION:
3550 add_global_procedure (0);
3551 push_state (&s, COMP_FUNCTION, gfc_new_block);
3552 accept_statement (st);
3553 parse_progunit (ST_NONE);
3554 break;
3555
3556 case ST_BLOCK_DATA:
3557 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3558 accept_statement (st);
3559 parse_block_data ();
3560 break;
3561
3562 case ST_MODULE:
3563 push_state (&s, COMP_MODULE, gfc_new_block);
3564 accept_statement (st);
3565
3566 gfc_get_errors (NULL, &errors_before);
3567 parse_module ();
3568 break;
3569
3570 /* Anything else starts a nameless main program block. */
3571 default:
3572 if (seen_program)
3573 goto duplicate_main;
3574 seen_program = 1;
3575 prog_locus = gfc_current_locus;
3576
3577 push_state (&s, COMP_PROGRAM, gfc_new_block);
3578 main_program_symbol (gfc_current_ns, "MAIN__");
3579 parse_progunit (st);
3580 break;
3581 }
3582
3583 gfc_current_ns->code = s.head;
3584
3585 gfc_resolve (gfc_current_ns);
3586
3587 /* Dump the parse tree if requested. */
3588 if (gfc_option.dump_parse_tree)
3589 gfc_dump_parse_tree (gfc_current_ns, stdout);
3590
3591 gfc_get_errors (NULL, &errors);
3592 if (s.state == COMP_MODULE)
3593 {
3594 gfc_dump_module (s.sym->name, errors_before == errors);
3595 if (errors == 0)
3596 gfc_generate_module_code (gfc_current_ns);
3597 }
3598 else
3599 {
3600 if (errors == 0)
3601 gfc_generate_code (gfc_current_ns);
3602 }
3603
3604 pop_state ();
3605 gfc_done_2 ();
3606 goto loop;
3607
3608 done:
3609 gfc_end_source_files ();
3610 return SUCCESS;
3611
3612 duplicate_main:
3613 /* If we see a duplicate main program, shut down. If the second
3614 instance is an implied main program, ie data decls or executable
3615 statements, we're in for lots of errors. */
3616 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3617 reject_statement ();
3618 gfc_done_2 ();
3619 return SUCCESS;
3620 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org