projects / gcc.git / blob
? search:


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