projects / gcc.git / blob
? search:


4bf1b811b196de76624efb2c286eda7fd9b8dd49
[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 accept_statement (ST_CONTAINS);
1719 gcc_assert (gfc_current_state () == COMP_DERIVED);
1720 push_state (&s, COMP_DERIVED_CONTAINS, NULL);
1721
1722 to_finish = false;
1723 while (!to_finish)
1724 {
1725 gfc_statement st;
1726 st = next_statement ();
1727 switch (st)
1728 {
1729 case ST_NONE:
1730 unexpected_eof ();
1731 break;
1732
1733 case ST_DATA_DECL:
1734 gfc_error ("Components in TYPE at %C must precede CONTAINS");
1735 error_flag = true;
1736 break;
1737
1738 case ST_PROCEDURE:
1739 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
1740 " procedure at %C") == FAILURE)
1741 error_flag = true;
1742
1743 accept_statement (ST_PROCEDURE);
1744 seen_comps = true;
1745 break;
1746
1747 case ST_FINAL:
1748 if (gfc_notify_std (GFC_STD_F2003,
1749 "Fortran 2003: FINAL procedure declaration"
1750 " at %C") == FAILURE)
1751 error_flag = true;
1752
1753 accept_statement (ST_FINAL);
1754 seen_comps = true;
1755 break;
1756
1757 case ST_END_TYPE:
1758 to_finish = true;
1759
1760 if (!seen_comps
1761 && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
1762 "definition at %C with empty CONTAINS "
1763 "section") == FAILURE))
1764 error_flag = true;
1765
1766 /* ST_END_TYPE is accepted by parse_derived after return. */
1767 break;
1768
1769 case ST_PRIVATE:
1770 if (gfc_find_state (COMP_MODULE) == FAILURE)
1771 {
1772 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1773 "a MODULE");
1774 error_flag = true;
1775 break;
1776 }
1777
1778 if (seen_comps)
1779 {
1780 gfc_error ("PRIVATE statement at %C must precede procedure"
1781 " bindings");
1782 error_flag = true;
1783 break;
1784 }
1785
1786 if (seen_private)
1787 {
1788 gfc_error ("Duplicate PRIVATE statement at %C");
1789 error_flag = true;
1790 }
1791
1792 accept_statement (ST_PRIVATE);
1793 seen_private = true;
1794 break;
1795
1796 case ST_SEQUENCE:
1797 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1798 error_flag = true;
1799 break;
1800
1801 case ST_CONTAINS:
1802 gfc_error ("Already inside a CONTAINS block at %C");
1803 error_flag = true;
1804 break;
1805
1806 default:
1807 unexpected_statement (st);
1808 break;
1809 }
1810 }
1811
1812 pop_state ();
1813 gcc_assert (gfc_current_state () == COMP_DERIVED);
1814
1815 /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
1816 to PUBLIC or PRIVATE depending on seen_private. */
1817 typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
1818 gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
1819 &set_typebound_default_access);
1820
1821 return error_flag;
1822 }
1823
1824
1825 /* Parse a derived type. */
1826
1827 static void
1828 parse_derived (void)
1829 {
1830 int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1831 gfc_statement st;
1832 gfc_state_data s;
1833 gfc_symbol *derived_sym = NULL;
1834 gfc_symbol *sym;
1835 gfc_component *c;
1836
1837 error_flag = 0;
1838
1839 accept_statement (ST_DERIVED_DECL);
1840 push_state (&s, COMP_DERIVED, gfc_new_block);
1841
1842 gfc_new_block->component_access = ACCESS_PUBLIC;
1843 seen_private = 0;
1844 seen_sequence = 0;
1845 seen_component = 0;
1846
1847 compiling_type = 1;
1848
1849 while (compiling_type)
1850 {
1851 st = next_statement ();
1852 switch (st)
1853 {
1854 case ST_NONE:
1855 unexpected_eof ();
1856
1857 case ST_DATA_DECL:
1858 accept_statement (st);
1859 seen_component = 1;
1860 break;
1861
1862 case ST_PROCEDURE:
1863 gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
1864 error_flag = 1;
1865 break;
1866
1867 case ST_FINAL:
1868 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
1869 error_flag = 1;
1870 break;
1871
1872 case ST_END_TYPE:
1873 endType:
1874 compiling_type = 0;
1875
1876 if (!seen_component
1877 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
1878 "definition at %C without components")
1879 == FAILURE))
1880 error_flag = 1;
1881
1882 accept_statement (ST_END_TYPE);
1883 break;
1884
1885 case ST_PRIVATE:
1886 if (gfc_find_state (COMP_MODULE) == FAILURE)
1887 {
1888 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1889 "a MODULE");
1890 error_flag = 1;
1891 break;
1892 }
1893
1894 if (seen_component)
1895 {
1896 gfc_error ("PRIVATE statement at %C must precede "
1897 "structure components");
1898 error_flag = 1;
1899 break;
1900 }
1901
1902 if (seen_private)
1903 {
1904 gfc_error ("Duplicate PRIVATE statement at %C");
1905 error_flag = 1;
1906 }
1907
1908 s.sym->component_access = ACCESS_PRIVATE;
1909
1910 accept_statement (ST_PRIVATE);
1911 seen_private = 1;
1912 break;
1913
1914 case ST_SEQUENCE:
1915 if (seen_component)
1916 {
1917 gfc_error ("SEQUENCE statement at %C must precede "
1918 "structure components");
1919 error_flag = 1;
1920 break;
1921 }
1922
1923 if (gfc_current_block ()->attr.sequence)
1924 gfc_warning ("SEQUENCE attribute at %C already specified in "
1925 "TYPE statement");
1926
1927 if (seen_sequence)
1928 {
1929 gfc_error ("Duplicate SEQUENCE statement at %C");
1930 error_flag = 1;
1931 }
1932
1933 seen_sequence = 1;
1934 gfc_add_sequence (&gfc_current_block ()->attr,
1935 gfc_current_block ()->name, NULL);
1936 break;
1937
1938 case ST_CONTAINS:
1939 if (gfc_notify_std (GFC_STD_F2003,
1940 "Fortran 2003: CONTAINS block in derived type"
1941 " definition at %C") == FAILURE)
1942 error_flag = 1;
1943
1944 accept_statement (ST_CONTAINS);
1945 if (parse_derived_contains ())
1946 error_flag = 1;
1947 goto endType;
1948
1949 default:
1950 unexpected_statement (st);
1951 break;
1952 }
1953 }
1954
1955 /* need to verify that all fields of the derived type are
1956 * interoperable with C if the type is declared to be bind(c)
1957 */
1958 derived_sym = gfc_current_block();
1959
1960 sym = gfc_current_block ();
1961 for (c = sym->components; c; c = c->next)
1962 {
1963 /* Look for allocatable components. */
1964 if (c->attr.allocatable
1965 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
1966 {
1967 sym->attr.alloc_comp = 1;
1968 break;
1969 }
1970
1971 /* Look for pointer components. */
1972 if (c->attr.pointer
1973 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
1974 {
1975 sym->attr.pointer_comp = 1;
1976 break;
1977 }
1978
1979 /* Look for private components. */
1980 if (sym->component_access == ACCESS_PRIVATE
1981 || c->attr.access == ACCESS_PRIVATE
1982 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
1983 {
1984 sym->attr.private_comp = 1;
1985 break;
1986 }
1987 }
1988
1989 if (!seen_component)
1990 sym->attr.zero_comp = 1;
1991
1992 pop_state ();
1993 }
1994
1995
1996 /* Parse an ENUM. */
1997
1998 static void
1999 parse_enum (void)
2000 {
2001 int error_flag;
2002 gfc_statement st;
2003 int compiling_enum;
2004 gfc_state_data s;
2005 int seen_enumerator = 0;
2006
2007 error_flag = 0;
2008
2009 push_state (&s, COMP_ENUM, gfc_new_block);
2010
2011 compiling_enum = 1;
2012
2013 while (compiling_enum)
2014 {
2015 st = next_statement ();
2016 switch (st)
2017 {
2018 case ST_NONE:
2019 unexpected_eof ();
2020 break;
2021
2022 case ST_ENUMERATOR:
2023 seen_enumerator = 1;
2024 accept_statement (st);
2025 break;
2026
2027 case ST_END_ENUM:
2028 compiling_enum = 0;
2029 if (!seen_enumerator)
2030 {
2031 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2032 error_flag = 1;
2033 }
2034 accept_statement (st);
2035 break;
2036
2037 default:
2038 gfc_free_enum_history ();
2039 unexpected_statement (st);
2040 break;
2041 }
2042 }
2043 pop_state ();
2044 }
2045
2046
2047 /* Parse an interface. We must be able to deal with the possibility
2048 of recursive interfaces. The parse_spec() subroutine is mutually
2049 recursive with parse_interface(). */
2050
2051 static gfc_statement parse_spec (gfc_statement);
2052
2053 static void
2054 parse_interface (void)
2055 {
2056 gfc_compile_state new_state, current_state;
2057 gfc_symbol *prog_unit, *sym;
2058 gfc_interface_info save;
2059 gfc_state_data s1, s2;
2060 gfc_statement st;
2061 locus proc_locus;
2062
2063 accept_statement (ST_INTERFACE);
2064
2065 current_interface.ns = gfc_current_ns;
2066 save = current_interface;
2067
2068 sym = (current_interface.type == INTERFACE_GENERIC
2069 || current_interface.type == INTERFACE_USER_OP)
2070 ? gfc_new_block : NULL;
2071
2072 push_state (&s1, COMP_INTERFACE, sym);
2073 current_state = COMP_NONE;
2074
2075 loop:
2076 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2077
2078 st = next_statement ();
2079 switch (st)
2080 {
2081 case ST_NONE:
2082 unexpected_eof ();
2083
2084 case ST_SUBROUTINE:
2085 case ST_FUNCTION:
2086 if (st == ST_SUBROUTINE)
2087 new_state = COMP_SUBROUTINE;
2088 else if (st == ST_FUNCTION)
2089 new_state = COMP_FUNCTION;
2090 if (gfc_new_block->attr.pointer)
2091 {
2092 gfc_new_block->attr.pointer = 0;
2093 gfc_new_block->attr.proc_pointer = 1;
2094 }
2095 if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2096 gfc_new_block->formal, NULL) == FAILURE)
2097 {
2098 reject_statement ();
2099 gfc_free_namespace (gfc_current_ns);
2100 goto loop;
2101 }
2102 if (current_interface.type != INTERFACE_ABSTRACT &&
2103 !gfc_new_block->attr.dummy &&
2104 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
2105 {
2106 reject_statement ();
2107 gfc_free_namespace (gfc_current_ns);
2108 goto loop;
2109 }
2110 break;
2111
2112 case ST_PROCEDURE:
2113 case ST_MODULE_PROC: /* The module procedure matcher makes
2114 sure the context is correct. */
2115 accept_statement (st);
2116 gfc_free_namespace (gfc_current_ns);
2117 goto loop;
2118
2119 case ST_END_INTERFACE:
2120 gfc_free_namespace (gfc_current_ns);
2121 gfc_current_ns = current_interface.ns;
2122 goto done;
2123
2124 default:
2125 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2126 gfc_ascii_statement (st));
2127 reject_statement ();
2128 gfc_free_namespace (gfc_current_ns);
2129 goto loop;
2130 }
2131
2132
2133 /* Make sure that a generic interface has only subroutines or
2134 functions and that the generic name has the right attribute. */
2135 if (current_interface.type == INTERFACE_GENERIC)
2136 {
2137 if (current_state == COMP_NONE)
2138 {
2139 if (new_state == COMP_FUNCTION)
2140 gfc_add_function (&sym->attr, sym->name, NULL);
2141 else if (new_state == COMP_SUBROUTINE)
2142 gfc_add_subroutine (&sym->attr, sym->name, NULL);
2143
2144 current_state = new_state;
2145 }
2146 else
2147 {
2148 if (new_state != current_state)
2149 {
2150 if (new_state == COMP_SUBROUTINE)
2151 gfc_error ("SUBROUTINE at %C does not belong in a "
2152 "generic function interface");
2153
2154 if (new_state == COMP_FUNCTION)
2155 gfc_error ("FUNCTION at %C does not belong in a "
2156 "generic subroutine interface");
2157 }
2158 }
2159 }
2160
2161 if (current_interface.type == INTERFACE_ABSTRACT)
2162 {
2163 gfc_new_block->attr.abstract = 1;
2164 if (gfc_is_intrinsic_typename (gfc_new_block->name))
2165 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2166 "cannot be the same as an intrinsic type",
2167 gfc_new_block->name);
2168 }
2169
2170 push_state (&s2, new_state, gfc_new_block);
2171 accept_statement (st);
2172 prog_unit = gfc_new_block;
2173 prog_unit->formal_ns = gfc_current_ns;
2174 proc_locus = gfc_current_locus;
2175
2176 decl:
2177 /* Read data declaration statements. */
2178 st = parse_spec (ST_NONE);
2179
2180 /* Since the interface block does not permit an IMPLICIT statement,
2181 the default type for the function or the result must be taken
2182 from the formal namespace. */
2183 if (new_state == COMP_FUNCTION)
2184 {
2185 if (prog_unit->result == prog_unit
2186 && prog_unit->ts.type == BT_UNKNOWN)
2187 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2188 else if (prog_unit->result != prog_unit
2189 && prog_unit->result->ts.type == BT_UNKNOWN)
2190 gfc_set_default_type (prog_unit->result, 1,
2191 prog_unit->formal_ns);
2192 }
2193
2194 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2195 {
2196 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2197 gfc_ascii_statement (st));
2198 reject_statement ();
2199 goto decl;
2200 }
2201
2202 current_interface = save;
2203 gfc_add_interface (prog_unit);
2204 pop_state ();
2205
2206 if (current_interface.ns
2207 && current_interface.ns->proc_name
2208 && strcmp (current_interface.ns->proc_name->name,
2209 prog_unit->name) == 0)
2210 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2211 "enclosing procedure", prog_unit->name, &proc_locus);
2212
2213 goto loop;
2214
2215 done:
2216 pop_state ();
2217 }
2218
2219
2220 /* Associate function characteristics by going back to the function
2221 declaration and rematching the prefix. */
2222
2223 static match
2224 match_deferred_characteristics (gfc_typespec * ts)
2225 {
2226 locus loc;
2227 match m = MATCH_ERROR;
2228 char name[GFC_MAX_SYMBOL_LEN + 1];
2229
2230 loc = gfc_current_locus;
2231
2232 gfc_current_locus = gfc_current_block ()->declared_at;
2233
2234 gfc_clear_error ();
2235 gfc_buffer_error (1);
2236 m = gfc_match_prefix (ts);
2237 gfc_buffer_error (0);
2238
2239 if (ts->type == BT_DERIVED)
2240 {
2241 ts->kind = 0;
2242
2243 if (!ts->derived || !ts->derived->components)
2244 m = MATCH_ERROR;
2245 }
2246
2247 /* Only permit one go at the characteristic association. */
2248 if (ts->kind == -1)
2249 ts->kind = 0;
2250
2251 /* Set the function locus correctly. If we have not found the
2252 function name, there is an error. */
2253 gfc_match ("function% %n", name);
2254 if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2255 {
2256 gfc_current_block ()->declared_at = gfc_current_locus;
2257 gfc_commit_symbols ();
2258 }
2259 else
2260 gfc_error_check ();
2261
2262 gfc_current_locus =loc;
2263 return m;
2264 }
2265
2266
2267 /* Check specification-expressions in the function result of the currently
2268 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2269 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2270 scope are not yet parsed so this has to be delayed up to parse_spec. */
2271
2272 static void
2273 check_function_result_typed (void)
2274 {
2275 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2276
2277 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2278 gcc_assert (ts->type != BT_UNKNOWN);
2279
2280 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2281 /* TODO: Extend when KIND type parameters are implemented. */
2282 if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
2283 gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
2284 }
2285
2286
2287 /* Parse a set of specification statements. Returns the statement
2288 that doesn't fit. */
2289
2290 static gfc_statement
2291 parse_spec (gfc_statement st)
2292 {
2293 st_state ss;
2294 bool function_result_typed = false;
2295 bool bad_characteristic = false;
2296 gfc_typespec *ts;
2297
2298 verify_st_order (&ss, ST_NONE, false);
2299 if (st == ST_NONE)
2300 st = next_statement ();
2301
2302 /* If we are not inside a function or don't have a result specified so far,
2303 do nothing special about it. */
2304 if (gfc_current_state () != COMP_FUNCTION)
2305 function_result_typed = true;
2306 else
2307 {
2308 gfc_symbol* proc = gfc_current_ns->proc_name;
2309 gcc_assert (proc);
2310
2311 if (proc->result->ts.type == BT_UNKNOWN)
2312 function_result_typed = true;
2313 }
2314
2315 loop:
2316
2317 /* If we find a statement that can not be followed by an IMPLICIT statement
2318 (and thus we can expect to see none any further), type the function result
2319 if it has not yet been typed. Be careful not to give the END statement
2320 to verify_st_order! */
2321 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2322 {
2323 bool verify_now = false;
2324
2325 if (st == ST_END_FUNCTION)
2326 verify_now = true;
2327 else
2328 {
2329 st_state dummyss;
2330 verify_st_order (&dummyss, ST_NONE, false);
2331 verify_st_order (&dummyss, st, false);
2332
2333 if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2334 verify_now = true;
2335 }
2336
2337 if (verify_now)
2338 {
2339 check_function_result_typed ();
2340 function_result_typed = true;
2341 }
2342 }
2343
2344 switch (st)
2345 {
2346 case ST_NONE:
2347 unexpected_eof ();
2348
2349 case ST_IMPLICIT_NONE:
2350 case ST_IMPLICIT:
2351 if (!function_result_typed)
2352 {
2353 check_function_result_typed ();
2354 function_result_typed = true;
2355 }
2356 goto declSt;
2357
2358 case ST_FORMAT:
2359 case ST_ENTRY:
2360 case ST_DATA: /* Not allowed in interfaces */
2361 if (gfc_current_state () == COMP_INTERFACE)
2362 break;
2363
2364 /* Fall through */
2365
2366 case ST_USE:
2367 case ST_IMPORT:
2368 case ST_PARAMETER:
2369 case ST_PUBLIC:
2370 case ST_PRIVATE:
2371 case ST_DERIVED_DECL:
2372 case_decl:
2373 declSt:
2374 if (verify_st_order (&ss, st, false) == FAILURE)
2375 {
2376 reject_statement ();
2377 st = next_statement ();
2378 goto loop;
2379 }
2380
2381 switch (st)
2382 {
2383 case ST_INTERFACE:
2384 parse_interface ();
2385 break;
2386
2387 case ST_DERIVED_DECL:
2388 parse_derived ();
2389 break;
2390
2391 case ST_PUBLIC:
2392 case ST_PRIVATE:
2393 if (gfc_current_state () != COMP_MODULE)
2394 {
2395 gfc_error ("%s statement must appear in a MODULE",
2396 gfc_ascii_statement (st));
2397 break;
2398 }
2399
2400 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2401 {
2402 gfc_error ("%s statement at %C follows another accessibility "
2403 "specification", gfc_ascii_statement (st));
2404 break;
2405 }
2406
2407 gfc_current_ns->default_access = (st == ST_PUBLIC)
2408 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2409
2410 break;
2411
2412 case ST_STATEMENT_FUNCTION:
2413 if (gfc_current_state () == COMP_MODULE)
2414 {
2415 unexpected_statement (st);
2416 break;
2417 }
2418
2419 default:
2420 break;
2421 }
2422
2423 accept_statement (st);
2424 st = next_statement ();
2425 goto loop;
2426
2427 case ST_ENUM:
2428 accept_statement (st);
2429 parse_enum();
2430 st = next_statement ();
2431 goto loop;
2432
2433 case ST_GET_FCN_CHARACTERISTICS:
2434 /* This statement triggers the association of a function's result
2435 characteristics. */
2436 ts = &gfc_current_block ()->result->ts;
2437 if (match_deferred_characteristics (ts) != MATCH_YES)
2438 bad_characteristic = true;
2439
2440 st = next_statement ();
2441 goto loop;
2442
2443 default:
2444 break;
2445 }
2446
2447 /* If match_deferred_characteristics failed, then there is an error. */
2448 if (bad_characteristic)
2449 {
2450 ts = &gfc_current_block ()->result->ts;
2451 if (ts->type != BT_DERIVED)
2452 gfc_error ("Bad kind expression for function '%s' at %L",
2453 gfc_current_block ()->name,
2454 &gfc_current_block ()->declared_at);
2455 else
2456 gfc_error ("The type for function '%s' at %L is not accessible",
2457 gfc_current_block ()->name,
2458 &gfc_current_block ()->declared_at);
2459
2460 gfc_current_block ()->ts.kind = 0;
2461 /* Keep the derived type; if it's bad, it will be discovered later. */
2462 if (!(ts->type == BT_DERIVED && ts->derived))
2463 ts->type = BT_UNKNOWN;
2464 }
2465
2466 return st;
2467 }
2468
2469
2470 /* Parse a WHERE block, (not a simple WHERE statement). */
2471
2472 static void
2473 parse_where_block (void)
2474 {
2475 int seen_empty_else;
2476 gfc_code *top, *d;
2477 gfc_state_data s;
2478 gfc_statement st;
2479
2480 accept_statement (ST_WHERE_BLOCK);
2481 top = gfc_state_stack->tail;
2482
2483 push_state (&s, COMP_WHERE, gfc_new_block);
2484
2485 d = add_statement ();
2486 d->expr = top->expr;
2487 d->op = EXEC_WHERE;
2488
2489 top->expr = NULL;
2490 top->block = d;
2491
2492 seen_empty_else = 0;
2493
2494 do
2495 {
2496 st = next_statement ();
2497 switch (st)
2498 {
2499 case ST_NONE:
2500 unexpected_eof ();
2501
2502 case ST_WHERE_BLOCK:
2503 parse_where_block ();
2504 break;
2505
2506 case ST_ASSIGNMENT:
2507 case ST_WHERE:
2508 accept_statement (st);
2509 break;
2510
2511 case ST_ELSEWHERE:
2512 if (seen_empty_else)
2513 {
2514 gfc_error ("ELSEWHERE statement at %C follows previous "
2515 "unmasked ELSEWHERE");
2516 break;
2517 }
2518
2519 if (new_st.expr == NULL)
2520 seen_empty_else = 1;
2521
2522 d = new_level (gfc_state_stack->head);
2523 d->op = EXEC_WHERE;
2524 d->expr = new_st.expr;
2525
2526 accept_statement (st);
2527
2528 break;
2529
2530 case ST_END_WHERE:
2531 accept_statement (st);
2532 break;
2533
2534 default:
2535 gfc_error ("Unexpected %s statement in WHERE block at %C",
2536 gfc_ascii_statement (st));
2537 reject_statement ();
2538 break;
2539 }
2540 }
2541 while (st != ST_END_WHERE);
2542
2543 pop_state ();
2544 }
2545
2546
2547 /* Parse a FORALL block (not a simple FORALL statement). */
2548
2549 static void
2550 parse_forall_block (void)
2551 {
2552 gfc_code *top, *d;
2553 gfc_state_data s;
2554 gfc_statement st;
2555
2556 accept_statement (ST_FORALL_BLOCK);
2557 top = gfc_state_stack->tail;
2558
2559 push_state (&s, COMP_FORALL, gfc_new_block);
2560
2561 d = add_statement ();
2562 d->op = EXEC_FORALL;
2563 top->block = d;
2564
2565 do
2566 {
2567 st = next_statement ();
2568 switch (st)
2569 {
2570
2571 case ST_ASSIGNMENT:
2572 case ST_POINTER_ASSIGNMENT:
2573 case ST_WHERE:
2574 case ST_FORALL:
2575 accept_statement (st);
2576 break;
2577
2578 case ST_WHERE_BLOCK:
2579 parse_where_block ();
2580 break;
2581
2582 case ST_FORALL_BLOCK:
2583 parse_forall_block ();
2584 break;
2585
2586 case ST_END_FORALL:
2587 accept_statement (st);
2588 break;
2589
2590 case ST_NONE:
2591 unexpected_eof ();
2592
2593 default:
2594 gfc_error ("Unexpected %s statement in FORALL block at %C",
2595 gfc_ascii_statement (st));
2596
2597 reject_statement ();
2598 break;
2599 }
2600 }
2601 while (st != ST_END_FORALL);
2602
2603 pop_state ();
2604 }
2605
2606
2607 static gfc_statement parse_executable (gfc_statement);
2608
2609 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2610
2611 static void
2612 parse_if_block (void)
2613 {
2614 gfc_code *top, *d;
2615 gfc_statement st;
2616 locus else_locus;
2617 gfc_state_data s;
2618 int seen_else;
2619
2620 seen_else = 0;
2621 accept_statement (ST_IF_BLOCK);
2622
2623 top = gfc_state_stack->tail;
2624 push_state (&s, COMP_IF, gfc_new_block);
2625
2626 new_st.op = EXEC_IF;
2627 d = add_statement ();
2628
2629 d->expr = top->expr;
2630 top->expr = NULL;
2631 top->block = d;
2632
2633 do
2634 {
2635 st = parse_executable (ST_NONE);
2636
2637 switch (st)
2638 {
2639 case ST_NONE:
2640 unexpected_eof ();
2641
2642 case ST_ELSEIF:
2643 if (seen_else)
2644 {
2645 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2646 "statement at %L", &else_locus);
2647
2648 reject_statement ();
2649 break;
2650 }
2651
2652 d = new_level (gfc_state_stack->head);
2653 d->op = EXEC_IF;
2654 d->expr = new_st.expr;
2655
2656 accept_statement (st);
2657
2658 break;
2659
2660 case ST_ELSE:
2661 if (seen_else)
2662 {
2663 gfc_error ("Duplicate ELSE statements at %L and %C",
2664 &else_locus);
2665 reject_statement ();
2666 break;
2667 }
2668
2669 seen_else = 1;
2670 else_locus = gfc_current_locus;
2671
2672 d = new_level (gfc_state_stack->head);
2673 d->op = EXEC_IF;
2674
2675 accept_statement (st);
2676
2677 break;
2678
2679 case ST_ENDIF:
2680 break;
2681
2682 default:
2683 unexpected_statement (st);
2684 break;
2685 }
2686 }
2687 while (st != ST_ENDIF);
2688
2689 pop_state ();
2690 accept_statement (st);
2691 }
2692
2693
2694 /* Parse a SELECT block. */
2695
2696 static void
2697 parse_select_block (void)
2698 {
2699 gfc_statement st;
2700 gfc_code *cp;
2701 gfc_state_data s;
2702
2703 accept_statement (ST_SELECT_CASE);
2704
2705 cp = gfc_state_stack->tail;
2706 push_state (&s, COMP_SELECT, gfc_new_block);
2707
2708 /* Make sure that the next statement is a CASE or END SELECT. */
2709 for (;;)
2710 {
2711 st = next_statement ();
2712 if (st == ST_NONE)
2713 unexpected_eof ();
2714 if (st == ST_END_SELECT)
2715 {
2716 /* Empty SELECT CASE is OK. */
2717 accept_statement (st);
2718 pop_state ();
2719 return;
2720 }
2721 if (st == ST_CASE)
2722 break;
2723
2724 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2725 "CASE at %C");
2726
2727 reject_statement ();
2728 }
2729
2730 /* At this point, we're got a nonempty select block. */
2731 cp = new_level (cp);
2732 *cp = new_st;
2733
2734 accept_statement (st);
2735
2736 do
2737 {
2738 st = parse_executable (ST_NONE);
2739 switch (st)
2740 {
2741 case ST_NONE:
2742 unexpected_eof ();
2743
2744 case ST_CASE:
2745 cp = new_level (gfc_state_stack->head);
2746 *cp = new_st;
2747 gfc_clear_new_st ();
2748
2749 accept_statement (st);
2750 /* Fall through */
2751
2752 case ST_END_SELECT:
2753 break;
2754
2755 /* Can't have an executable statement because of
2756 parse_executable(). */
2757 default:
2758 unexpected_statement (st);
2759 break;
2760 }
2761 }
2762 while (st != ST_END_SELECT);
2763
2764 pop_state ();
2765 accept_statement (st);
2766 }
2767
2768
2769 /* Given a symbol, make sure it is not an iteration variable for a DO
2770 statement. This subroutine is called when the symbol is seen in a
2771 context that causes it to become redefined. If the symbol is an
2772 iterator, we generate an error message and return nonzero. */
2773
2774 int
2775 gfc_check_do_variable (gfc_symtree *st)
2776 {
2777 gfc_state_data *s;
2778
2779 for (s=gfc_state_stack; s; s = s->previous)
2780 if (s->do_variable == st)
2781 {
2782 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2783 "loop beginning at %L", st->name, &s->head->loc);
2784 return 1;
2785 }
2786
2787 return 0;
2788 }
2789
2790
2791 /* Checks to see if the current statement label closes an enddo.
2792 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2793 an error) if it incorrectly closes an ENDDO. */
2794
2795 static int
2796 check_do_closure (void)
2797 {
2798 gfc_state_data *p;
2799
2800 if (gfc_statement_label == NULL)
2801 return 0;
2802
2803 for (p = gfc_state_stack; p; p = p->previous)
2804 if (p->state == COMP_DO)
2805 break;
2806
2807 if (p == NULL)
2808 return 0; /* No loops to close */
2809
2810 if (p->ext.end_do_label == gfc_statement_label)
2811 {
2812
2813 if (p == gfc_state_stack)
2814 return 1;
2815
2816 gfc_error ("End of nonblock DO statement at %C is within another block");
2817 return 2;
2818 }
2819
2820 /* At this point, the label doesn't terminate the innermost loop.
2821 Make sure it doesn't terminate another one. */
2822 for (; p; p = p->previous)
2823 if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2824 {
2825 gfc_error ("End of nonblock DO statement at %C is interwoven "
2826 "with another DO loop");
2827 return 2;
2828 }
2829
2830 return 0;
2831 }
2832
2833
2834 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2835 handled inside of parse_executable(), because they aren't really
2836 loop statements. */
2837
2838 static void
2839 parse_do_block (void)
2840 {
2841 gfc_statement st;
2842 gfc_code *top;
2843 gfc_state_data s;
2844 gfc_symtree *stree;
2845
2846 s.ext.end_do_label = new_st.label;
2847
2848 if (new_st.ext.iterator != NULL)
2849 stree = new_st.ext.iterator->var->symtree;
2850 else
2851 stree = NULL;
2852
2853 accept_statement (ST_DO);
2854
2855 top = gfc_state_stack->tail;
2856 push_state (&s, COMP_DO, gfc_new_block);
2857
2858 s.do_variable = stree;
2859
2860 top->block = new_level (top);
2861 top->block->op = EXEC_DO;
2862
2863 loop:
2864 st = parse_executable (ST_NONE);
2865
2866 switch (st)
2867 {
2868 case ST_NONE:
2869 unexpected_eof ();
2870
2871 case ST_ENDDO:
2872 if (s.ext.end_do_label != NULL
2873 && s.ext.end_do_label != gfc_statement_label)
2874 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2875 "DO label");
2876
2877 if (gfc_statement_label != NULL)
2878 {
2879 new_st.op = EXEC_NOP;
2880 add_statement ();
2881 }
2882 break;
2883
2884 case ST_IMPLIED_ENDDO:
2885 /* If the do-stmt of this DO construct has a do-construct-name,
2886 the corresponding end-do must be an end-do-stmt (with a matching
2887 name, but in that case we must have seen ST_ENDDO first).
2888 We only complain about this in pedantic mode. */
2889 if (gfc_current_block () != NULL)
2890 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2891 &gfc_current_block()->declared_at);
2892
2893 break;
2894
2895 default:
2896 unexpected_statement (st);
2897 goto loop;
2898 }
2899
2900 pop_state ();
2901 accept_statement (st);
2902 }
2903
2904
2905 /* Parse the statements of OpenMP do/parallel do. */
2906
2907 static gfc_statement
2908 parse_omp_do (gfc_statement omp_st)
2909 {
2910 gfc_statement st;
2911 gfc_code *cp, *np;
2912 gfc_state_data s;
2913
2914 accept_statement (omp_st);
2915
2916 cp = gfc_state_stack->tail;
2917 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2918 np = new_level (cp);
2919 np->op = cp->op;
2920 np->block = NULL;
2921
2922 for (;;)
2923 {
2924 st = next_statement ();
2925 if (st == ST_NONE)
2926 unexpected_eof ();
2927 else if (st == ST_DO)
2928 break;
2929 else
2930 unexpected_statement (st);
2931 }
2932
2933 parse_do_block ();
2934 if (gfc_statement_label != NULL
2935 && gfc_state_stack->previous != NULL
2936 && gfc_state_stack->previous->state == COMP_DO
2937 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2938 {
2939 /* In
2940 DO 100 I=1,10
2941 !$OMP DO
2942 DO J=1,10
2943 ...
2944 100 CONTINUE
2945 there should be no !$OMP END DO. */
2946 pop_state ();
2947 return ST_IMPLIED_ENDDO;
2948 }
2949
2950 check_do_closure ();
2951 pop_state ();
2952
2953 st = next_statement ();
2954 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2955 {
2956 if (new_st.op == EXEC_OMP_END_NOWAIT)
2957 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2958 else
2959 gcc_assert (new_st.op == EXEC_NOP);
2960 gfc_clear_new_st ();
2961 gfc_commit_symbols ();
2962 gfc_warning_check ();
2963 st = next_statement ();
2964 }
2965 return st;
2966 }
2967
2968
2969 /* Parse the statements of OpenMP atomic directive. */
2970
2971 static void
2972 parse_omp_atomic (void)
2973 {
2974 gfc_statement st;
2975 gfc_code *cp, *np;
2976 gfc_state_data s;
2977
2978 accept_statement (ST_OMP_ATOMIC);
2979
2980 cp = gfc_state_stack->tail;
2981 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2982 np = new_level (cp);
2983 np->op = cp->op;
2984 np->block = NULL;
2985
2986 for (;;)
2987 {
2988 st = next_statement ();
2989 if (st == ST_NONE)
2990 unexpected_eof ();
2991 else if (st == ST_ASSIGNMENT)
2992 break;
2993 else
2994 unexpected_statement (st);
2995 }
2996
2997 accept_statement (st);
2998
2999 pop_state ();
3000 }
3001
3002
3003 /* Parse the statements of an OpenMP structured block. */
3004
3005 static void
3006 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3007 {
3008 gfc_statement st, omp_end_st;
3009 gfc_code *cp, *np;
3010 gfc_state_data s;
3011
3012 accept_statement (omp_st);
3013
3014 cp = gfc_state_stack->tail;
3015 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3016 np = new_level (cp);
3017 np->op = cp->op;
3018 np->block = NULL;
3019
3020 switch (omp_st)
3021 {
3022 case ST_OMP_PARALLEL:
3023 omp_end_st = ST_OMP_END_PARALLEL;
3024 break;
3025 case ST_OMP_PARALLEL_SECTIONS:
3026 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3027 break;
3028 case ST_OMP_SECTIONS:
3029 omp_end_st = ST_OMP_END_SECTIONS;
3030 break;
3031 case ST_OMP_ORDERED:
3032 omp_end_st = ST_OMP_END_ORDERED;
3033 break;
3034 case ST_OMP_CRITICAL:
3035 omp_end_st = ST_OMP_END_CRITICAL;
3036 break;
3037 case ST_OMP_MASTER:
3038 omp_end_st = ST_OMP_END_MASTER;
3039 break;
3040 case ST_OMP_SINGLE:
3041 omp_end_st = ST_OMP_END_SINGLE;
3042 break;
3043 case ST_OMP_TASK:
3044 omp_end_st = ST_OMP_END_TASK;
3045 break;
3046 case ST_OMP_WORKSHARE:
3047 omp_end_st = ST_OMP_END_WORKSHARE;
3048 break;
3049 case ST_OMP_PARALLEL_WORKSHARE:
3050 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3051 break;
3052 default:
3053 gcc_unreachable ();
3054 }
3055
3056 do
3057 {
3058 if (workshare_stmts_only)
3059 {
3060 /* Inside of !$omp workshare, only
3061 scalar assignments
3062 array assignments
3063 where statements and constructs
3064 forall statements and constructs
3065 !$omp atomic
3066 !$omp critical
3067 !$omp parallel
3068 are allowed. For !$omp critical these
3069 restrictions apply recursively. */
3070 bool cycle = true;
3071
3072 st = next_statement ();
3073 for (;;)
3074 {
3075 switch (st)
3076 {
3077 case ST_NONE:
3078 unexpected_eof ();
3079
3080 case ST_ASSIGNMENT:
3081 case ST_WHERE:
3082 case ST_FORALL:
3083 accept_statement (st);
3084 break;
3085
3086 case ST_WHERE_BLOCK:
3087 parse_where_block ();
3088 break;
3089
3090 case ST_FORALL_BLOCK:
3091 parse_forall_block ();
3092 break;
3093
3094 case ST_OMP_PARALLEL:
3095 case ST_OMP_PARALLEL_SECTIONS:
3096 parse_omp_structured_block (st, false);
3097 break;
3098
3099 case ST_OMP_PARALLEL_WORKSHARE:
3100 case ST_OMP_CRITICAL:
3101 parse_omp_structured_block (st, true);
3102 break;
3103
3104 case ST_OMP_PARALLEL_DO:
3105 st = parse_omp_do (st);
3106 continue;
3107
3108 case ST_OMP_ATOMIC:
3109 parse_omp_atomic ();
3110 break;
3111
3112 default:
3113 cycle = false;
3114 break;
3115 }
3116
3117 if (!cycle)
3118 break;
3119
3120 st = next_statement ();
3121 }
3122 }
3123 else
3124 st = parse_executable (ST_NONE);
3125 if (st == ST_NONE)
3126 unexpected_eof ();
3127 else if (st == ST_OMP_SECTION
3128 && (omp_st == ST_OMP_SECTIONS
3129 || omp_st == ST_OMP_PARALLEL_SECTIONS))
3130 {
3131 np = new_level (np);
3132 np->op = cp->op;
3133 np->block = NULL;
3134 }
3135 else if (st != omp_end_st)
3136 unexpected_statement (st);
3137 }
3138 while (st != omp_end_st);
3139
3140 switch (new_st.op)
3141 {
3142 case EXEC_OMP_END_NOWAIT:
3143 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3144 break;
3145 case EXEC_OMP_CRITICAL:
3146 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3147 || (new_st.ext.omp_name != NULL
3148 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3149 gfc_error ("Name after !$omp critical and !$omp end critical does "
3150 "not match at %C");
3151 gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3152 break;
3153 case EXEC_OMP_END_SINGLE:
3154 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3155 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3156 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3157 gfc_free_omp_clauses (new_st.ext.omp_clauses);
3158 break;
3159 case EXEC_NOP:
3160 break;
3161 default:
3162 gcc_unreachable ();
3163 }
3164
3165 gfc_clear_new_st ();
3166 gfc_commit_symbols ();
3167 gfc_warning_check ();
3168 pop_state ();
3169 }
3170
3171
3172 /* Accept a series of executable statements. We return the first
3173 statement that doesn't fit to the caller. Any block statements are
3174 passed on to the correct handler, which usually passes the buck
3175 right back here. */
3176
3177 static gfc_statement
3178 parse_executable (gfc_statement st)
3179 {
3180 int close_flag;
3181
3182 if (st == ST_NONE)
3183 st = next_statement ();
3184
3185 for (;;)
3186 {
3187 close_flag = check_do_closure ();
3188 if (close_flag)
3189 switch (st)
3190 {
3191 case ST_GOTO:
3192 case ST_END_PROGRAM:
3193 case ST_RETURN:
3194 case ST_EXIT:
3195 case ST_END_FUNCTION:
3196 case ST_CYCLE:
3197 case ST_PAUSE:
3198 case ST_STOP:
3199 case ST_END_SUBROUTINE:
3200
3201 case ST_DO:
3202 case ST_FORALL:
3203 case ST_WHERE:
3204 case ST_SELECT_CASE:
3205 gfc_error ("%s statement at %C cannot terminate a non-block "
3206 "DO loop", gfc_ascii_statement (st));
3207 break;
3208
3209 default:
3210 break;
3211 }
3212
3213 switch (st)
3214 {
3215 case ST_NONE:
3216 unexpected_eof ();
3217
3218 case ST_FORMAT:
3219 case ST_DATA:
3220 case ST_ENTRY:
3221 case_executable:
3222 accept_statement (st);
3223 if (close_flag == 1)
3224 return ST_IMPLIED_ENDDO;
3225 break;
3226
3227 case ST_IF_BLOCK:
3228 parse_if_block ();
3229 break;
3230
3231 case ST_SELECT_CASE:
3232 parse_select_block ();
3233 break;
3234
3235 case ST_DO:
3236 parse_do_block ();
3237 if (check_do_closure () == 1)
3238 return ST_IMPLIED_ENDDO;
3239 break;
3240
3241 case ST_WHERE_BLOCK:
3242 parse_where_block ();
3243 break;
3244
3245 case ST_FORALL_BLOCK:
3246 parse_forall_block ();
3247 break;
3248
3249 case ST_OMP_PARALLEL:
3250 case ST_OMP_PARALLEL_SECTIONS:
3251 case ST_OMP_SECTIONS:
3252 case ST_OMP_ORDERED:
3253 case ST_OMP_CRITICAL:
3254 case ST_OMP_MASTER:
3255 case ST_OMP_SINGLE:
3256 case ST_OMP_TASK:
3257 parse_omp_structured_block (st, false);
3258 break;
3259
3260 case ST_OMP_WORKSHARE:
3261 case ST_OMP_PARALLEL_WORKSHARE:
3262 parse_omp_structured_block (st, true);
3263 break;
3264
3265 case ST_OMP_DO:
3266 case ST_OMP_PARALLEL_DO:
3267 st = parse_omp_do (st);
3268 if (st == ST_IMPLIED_ENDDO)
3269 return st;
3270 continue;
3271
3272 case ST_OMP_ATOMIC:
3273 parse_omp_atomic ();
3274 break;
3275
3276 default:
3277 return st;
3278 }
3279
3280 st = next_statement ();
3281 }
3282 }
3283
3284
3285 /* Parse a series of contained program units. */
3286
3287 static void parse_progunit (gfc_statement);
3288
3289
3290 /* Fix the symbols for sibling functions. These are incorrectly added to
3291 the child namespace as the parser didn't know about this procedure. */
3292
3293 static void
3294 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3295 {
3296 gfc_namespace *ns;
3297 gfc_symtree *st;
3298 gfc_symbol *old_sym;
3299
3300 sym->attr.referenced = 1;
3301 for (ns = siblings; ns; ns = ns->sibling)
3302 {
3303 gfc_find_sym_tree (sym->name, ns, 0, &st);
3304
3305 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3306 continue;
3307
3308 old_sym = st->n.sym;
3309 if (old_sym->ns == ns
3310 && !old_sym->attr.contained
3311
3312 /* By 14.6.1.3, host association should be excluded
3313 for the following. */
3314 && !(old_sym->attr.external
3315 || (old_sym->ts.type != BT_UNKNOWN
3316 && !old_sym->attr.implicit_type)
3317 || old_sym->attr.flavor == FL_PARAMETER
3318 || old_sym->attr.in_common
3319 || old_sym->attr.in_equivalence
3320 || old_sym->attr.data
3321 || old_sym->attr.dummy
3322 || old_sym->attr.result
3323 || old_sym->attr.dimension
3324 || old_sym->attr.allocatable
3325 || old_sym->attr.intrinsic
3326 || old_sym->attr.generic
3327 || old_sym->attr.flavor == FL_NAMELIST
3328 || old_sym->attr.proc == PROC_ST_FUNCTION))
3329 {
3330 /* Replace it with the symbol from the parent namespace. */
3331 st->n.sym = sym;
3332 sym->refs++;
3333
3334 /* Free the old (local) symbol. */
3335 old_sym->refs--;
3336 if (old_sym->refs == 0)
3337 gfc_free_symbol (old_sym);
3338 }
3339
3340 /* Do the same for any contained procedures. */
3341 gfc_fixup_sibling_symbols (sym, ns->contained);
3342 }
3343 }
3344
3345 static void
3346 parse_contained (int module)
3347 {
3348 gfc_namespace *ns, *parent_ns, *tmp;
3349 gfc_state_data s1, s2;
3350 gfc_statement st;
3351 gfc_symbol *sym;
3352 gfc_entry_list *el;
3353 int contains_statements = 0;
3354 int seen_error = 0;
3355
3356 push_state (&s1, COMP_CONTAINS, NULL);
3357 parent_ns = gfc_current_ns;
3358
3359 do
3360 {
3361 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3362
3363 gfc_current_ns->sibling = parent_ns->contained;
3364 parent_ns->contained = gfc_current_ns;
3365
3366 next:
3367 /* Process the next available statement. We come here if we got an error
3368 and rejected the last statement. */
3369 st = next_statement ();
3370
3371 switch (st)
3372 {
3373 case ST_NONE:
3374 unexpected_eof ();
3375
3376 case ST_FUNCTION:
3377 case ST_SUBROUTINE:
3378 contains_statements = 1;
3379 accept_statement (st);
3380
3381 push_state (&s2,
3382 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3383 gfc_new_block);
3384
3385 /* For internal procedures, create/update the symbol in the
3386 parent namespace. */
3387
3388 if (!module)
3389 {
3390 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3391 gfc_error ("Contained procedure '%s' at %C is already "
3392 "ambiguous", gfc_new_block->name);
3393 else
3394 {
3395 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3396 &gfc_new_block->declared_at) ==
3397 SUCCESS)
3398 {
3399 if (st == ST_FUNCTION)
3400 gfc_add_function (&sym->attr, sym->name,
3401 &gfc_new_block->declared_at);
3402 else
3403 gfc_add_subroutine (&sym->attr, sym->name,
3404 &gfc_new_block->declared_at);
3405 }
3406 }
3407
3408 gfc_commit_symbols ();
3409 }
3410 else
3411 sym = gfc_new_block;
3412
3413 /* Mark this as a contained function, so it isn't replaced
3414 by other module functions. */
3415 sym->attr.contained = 1;
3416 sym->attr.referenced = 1;
3417
3418 parse_progunit (ST_NONE);
3419
3420 /* Fix up any sibling functions that refer to this one. */
3421 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3422 /* Or refer to any of its alternate entry points. */
3423 for (el = gfc_current_ns->entries; el; el = el->next)
3424 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3425
3426 gfc_current_ns->code = s2.head;
3427 gfc_current_ns = parent_ns;
3428
3429 pop_state ();
3430 break;
3431
3432 /* These statements are associated with the end of the host unit. */
3433 case ST_END_FUNCTION:
3434 case ST_END_MODULE:
3435 case ST_END_PROGRAM:
3436 case ST_END_SUBROUTINE:
3437 accept_statement (st);
3438 break;
3439
3440 default:
3441 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3442 gfc_ascii_statement (st));
3443 reject_statement ();
3444 seen_error = 1;
3445 goto next;
3446 break;
3447 }
3448 }
3449 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3450 && st != ST_END_MODULE && st != ST_END_PROGRAM);
3451
3452 /* The first namespace in the list is guaranteed to not have
3453 anything (worthwhile) in it. */
3454 tmp = gfc_current_ns;
3455 gfc_current_ns = parent_ns;
3456 if (seen_error && tmp->refs > 1)
3457 gfc_free_namespace (tmp);
3458
3459 ns = gfc_current_ns->contained;
3460 gfc_current_ns->contained = ns->sibling;
3461 gfc_free_namespace (ns);
3462
3463 pop_state ();
3464 if (!contains_statements)
3465 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3466 "FUNCTION or SUBROUTINE statement at %C");
3467 }
3468
3469
3470 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
3471
3472 static void
3473 parse_progunit (gfc_statement st)
3474 {
3475 gfc_state_data *p;
3476 int n;
3477
3478 st = parse_spec (st);
3479 switch (st)
3480 {
3481 case ST_NONE:
3482 unexpected_eof ();
3483
3484 case ST_CONTAINS:
3485 goto contains;
3486
3487 case_end:
3488 accept_statement (st);
3489 goto done;
3490
3491 default:
3492 break;
3493 }
3494
3495 if (gfc_current_state () == COMP_FUNCTION)
3496 gfc_check_function_type (gfc_current_ns);
3497
3498 loop:
3499 for (;;)
3500 {
3501 st = parse_executable (st);
3502
3503 switch (st)
3504 {
3505 case ST_NONE:
3506 unexpected_eof ();
3507
3508 case ST_CONTAINS:
3509 goto contains;
3510
3511 case_end:
3512 accept_statement (st);
3513 goto done;
3514
3515 default:
3516 break;
3517 }
3518
3519 unexpected_statement (st);
3520 reject_statement ();
3521 st = next_statement ();
3522 }
3523
3524 contains:
3525 n = 0;
3526
3527 for (p = gfc_state_stack; p; p = p->previous)
3528 if (p->state == COMP_CONTAINS)
3529 n++;
3530
3531 if (gfc_find_state (COMP_MODULE) == SUCCESS)
3532 n--;
3533
3534 if (n > 0)
3535 {
3536 gfc_error ("CONTAINS statement at %C is already in a contained "
3537 "program unit");
3538 st = next_statement ();
3539 goto loop;
3540 }
3541
3542 parse_contained (0);
3543
3544 done:
3545 gfc_current_ns->code = gfc_state_stack->head;
3546 }
3547
3548
3549 /* Come here to complain about a global symbol already in use as
3550 something else. */
3551
3552 void
3553 gfc_global_used (gfc_gsymbol *sym, locus *where)
3554 {
3555 const char *name;
3556
3557 if (where == NULL)
3558 where = &gfc_current_locus;
3559
3560 switch(sym->type)
3561 {
3562 case GSYM_PROGRAM:
3563 name = "PROGRAM";
3564 break;
3565 case GSYM_FUNCTION:
3566 name = "FUNCTION";
3567 break;
3568 case GSYM_SUBROUTINE:
3569 name = "SUBROUTINE";
3570 break;
3571 case GSYM_COMMON:
3572 name = "COMMON";
3573 break;
3574 case GSYM_BLOCK_DATA:
3575 name = "BLOCK DATA";
3576 break;
3577 case GSYM_MODULE:
3578 name = "MODULE";
3579 break;
3580 default:
3581 gfc_internal_error ("gfc_global_used(): Bad type");
3582 name = NULL;
3583 }
3584
3585 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3586 sym->name, where, name, &sym->where);
3587 }
3588
3589
3590 /* Parse a block data program unit. */
3591
3592 static void
3593 parse_block_data (void)
3594 {
3595 gfc_statement st;
3596 static locus blank_locus;
3597 static int blank_block=0;
3598 gfc_gsymbol *s;
3599
3600 gfc_current_ns->proc_name = gfc_new_block;
3601 gfc_current_ns->is_block_data = 1;
3602
3603 if (gfc_new_block == NULL)
3604 {
3605 if (blank_block)
3606 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3607 "prior BLOCK DATA at %L", &blank_locus);
3608 else
3609 {
3610 blank_block = 1;
3611 blank_locus = gfc_current_locus;
3612 }
3613 }
3614 else
3615 {
3616 s = gfc_get_gsymbol (gfc_new_block->name);
3617 if (s->defined
3618 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3619 gfc_global_used(s, NULL);
3620 else
3621 {
3622 s->type = GSYM_BLOCK_DATA;
3623 s->where = gfc_current_locus;
3624 s->defined = 1;
3625 }
3626 }
3627
3628 st = parse_spec (ST_NONE);
3629
3630 while (st != ST_END_BLOCK_DATA)
3631 {
3632 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3633 gfc_ascii_statement (st));
3634 reject_statement ();
3635 st = next_statement ();
3636 }
3637 }
3638
3639
3640 /* Parse a module subprogram. */
3641
3642 static void
3643 parse_module (void)
3644 {
3645 gfc_statement st;
3646 gfc_gsymbol *s;
3647
3648 s = gfc_get_gsymbol (gfc_new_block->name);
3649 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3650 gfc_global_used(s, NULL);
3651 else
3652 {
3653 s->type = GSYM_MODULE;
3654 s->where = gfc_current_locus;
3655 s->defined = 1;
3656 }
3657
3658 st = parse_spec (ST_NONE);
3659
3660 loop:
3661 switch (st)
3662 {
3663 case ST_NONE:
3664 unexpected_eof ();
3665
3666 case ST_CONTAINS:
3667 parse_contained (1);
3668 break;
3669
3670 case ST_END_MODULE:
3671 accept_statement (st);
3672 break;
3673
3674 default:
3675 gfc_error ("Unexpected %s statement in MODULE at %C",
3676 gfc_ascii_statement (st));
3677
3678 reject_statement ();
3679 st = next_statement ();
3680 goto loop;
3681 }
3682 }
3683
3684
3685 /* Add a procedure name to the global symbol table. */
3686
3687 static void
3688 add_global_procedure (int sub)
3689 {
3690 gfc_gsymbol *s;
3691
3692 s = gfc_get_gsymbol(gfc_new_block->name);
3693
3694 if (s->defined
3695 || (s->type != GSYM_UNKNOWN
3696 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3697 gfc_global_used(s, NULL);
3698 else
3699 {
3700 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3701 s->where = gfc_current_locus;
3702 s->defined = 1;
3703 }
3704 }
3705
3706
3707 /* Add a program to the global symbol table. */
3708
3709 static void
3710 add_global_program (void)
3711 {
3712 gfc_gsymbol *s;
3713
3714 if (gfc_new_block == NULL)
3715 return;
3716 s = gfc_get_gsymbol (gfc_new_block->name);
3717
3718 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3719 gfc_global_used(s, NULL);
3720 else
3721 {
3722 s->type = GSYM_PROGRAM;
3723 s->where = gfc_current_locus;
3724 s->defined = 1;
3725 }
3726 }
3727
3728
3729 /* Top level parser. */
3730
3731 gfc_try
3732 gfc_parse_file (void)
3733 {
3734 int seen_program, errors_before, errors;
3735 gfc_state_data top, s;
3736 gfc_statement st;
3737 locus prog_locus;
3738
3739 gfc_start_source_files ();
3740
3741 top.state = COMP_NONE;
3742 top.sym = NULL;
3743 top.previous = NULL;
3744 top.head = top.tail = NULL;
3745 top.do_variable = NULL;
3746
3747 gfc_state_stack = &top;
3748
3749 gfc_clear_new_st ();
3750
3751 gfc_statement_label = NULL;
3752
3753 if (setjmp (eof_buf))
3754 return FAILURE; /* Come here on unexpected EOF */
3755
3756 seen_program = 0;
3757
3758 /* Exit early for empty files. */
3759 if (gfc_at_eof ())
3760 goto done;
3761
3762 loop:
3763 gfc_init_2 ();
3764 st = next_statement ();
3765 switch (st)
3766 {
3767 case ST_NONE:
3768 gfc_done_2 ();
3769 goto done;
3770
3771 case ST_PROGRAM:
3772 if (seen_program)
3773 goto duplicate_main;
3774 seen_program = 1;
3775 prog_locus = gfc_current_locus;
3776
3777 push_state (&s, COMP_PROGRAM, gfc_new_block);
3778 main_program_symbol(gfc_current_ns, gfc_new_block->name);
3779 accept_statement (st);
3780 add_global_program ();
3781 parse_progunit (ST_NONE);
3782 break;
3783
3784 case ST_SUBROUTINE:
3785 add_global_procedure (1);
3786 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3787 accept_statement (st);
3788 parse_progunit (ST_NONE);
3789 break;
3790
3791 case ST_FUNCTION:
3792 add_global_procedure (0);
3793 push_state (&s, COMP_FUNCTION, gfc_new_block);
3794 accept_statement (st);
3795 parse_progunit (ST_NONE);
3796 break;
3797
3798 case ST_BLOCK_DATA:
3799 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3800 accept_statement (st);
3801 parse_block_data ();
3802 break;
3803
3804 case ST_MODULE:
3805 push_state (&s, COMP_MODULE, gfc_new_block);
3806 accept_statement (st);
3807
3808 gfc_get_errors (NULL, &errors_before);
3809 parse_module ();
3810 break;
3811
3812 /* Anything else starts a nameless main program block. */
3813 default:
3814 if (seen_program)
3815 goto duplicate_main;
3816 seen_program = 1;
3817 prog_locus = gfc_current_locus;
3818
3819 push_state (&s, COMP_PROGRAM, gfc_new_block);
3820 main_program_symbol (gfc_current_ns, "MAIN__");
3821 parse_progunit (st);
3822 break;
3823 }
3824
3825 gfc_current_ns->code = s.head;
3826
3827 gfc_resolve (gfc_current_ns);
3828
3829 /* Dump the parse tree if requested. */
3830 if (gfc_option.dump_parse_tree)
3831 gfc_dump_parse_tree (gfc_current_ns, stdout);
3832
3833 gfc_get_errors (NULL, &errors);
3834 if (s.state == COMP_MODULE)
3835 {
3836 gfc_dump_module (s.sym->name, errors_before == errors);
3837 if (errors == 0)
3838 gfc_generate_module_code (gfc_current_ns);
3839 }
3840 else
3841 {
3842 if (errors == 0)
3843 gfc_generate_code (gfc_current_ns);
3844 }
3845
3846 pop_state ();
3847 gfc_done_2 ();
3848 goto loop;
3849
3850 done:
3851 gfc_end_source_files ();
3852 return SUCCESS;
3853
3854 duplicate_main:
3855 /* If we see a duplicate main program, shut down. If the second
3856 instance is an implied main program, i.e. data decls or executable
3857 statements, we're in for lots of errors. */
3858 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3859 reject_statement ();
3860 gfc_done_2 ();
3861 return SUCCESS;
3862 }