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