projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
ipa-cp.c (ipcp_cloning_candidate_p): Use opt_for_fn.
[gcc.git] / gcc / fortran / parse.c
1 /* Main parser.
2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 #include "config.h"
22 #include "system.h"
23 #include <setjmp.h>
24 #include "coretypes.h"
25 #include "gfortran.h"
26 #include "match.h"
27 #include "parse.h"
28 #include "debug.h"
29
30 /* Current statement label. Zero means no statement label. Because new_st
31 can get wiped during statement matching, we have to keep it separate. */
32
33 gfc_st_label *gfc_statement_label;
34
35 static locus label_locus;
36 static jmp_buf eof_buf;
37
38 gfc_state_data *gfc_state_stack;
39 static bool last_was_use_stmt = false;
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 /* Like match_word, but if str is matched, set a flag that it
78 was matched. */
79 static match
80 match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
81 bool *simd_matched)
82 {
83 match m;
84
85 if (str != NULL)
86 {
87 m = gfc_match (str);
88 if (m != MATCH_YES)
89 return m;
90 *simd_matched = true;
91 }
92
93 m = (*subr) ();
94
95 if (m != MATCH_YES)
96 {
97 gfc_current_locus = *old_locus;
98 reject_statement ();
99 }
100
101 return m;
102 }
103
104
105 /* Load symbols from all USE statements encountered in this scoping unit. */
106
107 static void
108 use_modules (void)
109 {
110 gfc_error_buf old_error;
111
112 gfc_push_error (&old_error);
113 gfc_buffer_error (0);
114 gfc_use_modules ();
115 gfc_buffer_error (1);
116 gfc_pop_error (&old_error);
117 gfc_commit_symbols ();
118 gfc_warning_check ();
119 gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
120 gfc_current_ns->old_equiv = gfc_current_ns->equiv;
121 last_was_use_stmt = false;
122 }
123
124
125 /* Figure out what the next statement is, (mostly) regardless of
126 proper ordering. The do...while(0) is there to prevent if/else
127 ambiguity. */
128
129 #define match(keyword, subr, st) \
130 do { \
131 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
132 return st; \
133 else \
134 undo_new_statement (); \
135 } while (0);
136
137
138 /* This is a specialist version of decode_statement that is used
139 for the specification statements in a function, whose
140 characteristics are deferred into the specification statements.
141 eg.: INTEGER (king = mykind) foo ()
142 USE mymodule, ONLY mykind.....
143 The KIND parameter needs a return after USE or IMPORT, whereas
144 derived type declarations can occur anywhere, up the executable
145 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
146 out of the correct kind of specification statements. */
147 static gfc_statement
148 decode_specification_statement (void)
149 {
150 gfc_statement st;
151 locus old_locus;
152 char c;
153
154 if (gfc_match_eos () == MATCH_YES)
155 return ST_NONE;
156
157 old_locus = gfc_current_locus;
158
159 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
160 {
161 last_was_use_stmt = true;
162 return ST_USE;
163 }
164 else
165 {
166 undo_new_statement ();
167 if (last_was_use_stmt)
168 use_modules ();
169 }
170
171 match ("import", gfc_match_import, ST_IMPORT);
172
173 if (gfc_current_block ()->result->ts.type != BT_DERIVED)
174 goto end_of_block;
175
176 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
177 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
178 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
179
180 /* General statement matching: Instead of testing every possible
181 statement, we eliminate most possibilities by peeking at the
182 first character. */
183
184 c = gfc_peek_ascii_char ();
185
186 switch (c)
187 {
188 case 'a':
189 match ("abstract% interface", gfc_match_abstract_interface,
190 ST_INTERFACE);
191 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
192 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
193 break;
194
195 case 'b':
196 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
197 break;
198
199 case 'c':
200 match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
201 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
202 break;
203
204 case 'd':
205 match ("data", gfc_match_data, ST_DATA);
206 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
207 break;
208
209 case 'e':
210 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
211 match ("entry% ", gfc_match_entry, ST_ENTRY);
212 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
213 match ("external", gfc_match_external, ST_ATTR_DECL);
214 break;
215
216 case 'f':
217 match ("format", gfc_match_format, ST_FORMAT);
218 break;
219
220 case 'g':
221 break;
222
223 case 'i':
224 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
225 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
226 match ("interface", gfc_match_interface, ST_INTERFACE);
227 match ("intent", gfc_match_intent, ST_ATTR_DECL);
228 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
229 break;
230
231 case 'm':
232 break;
233
234 case 'n':
235 match ("namelist", gfc_match_namelist, ST_NAMELIST);
236 break;
237
238 case 'o':
239 match ("optional", gfc_match_optional, ST_ATTR_DECL);
240 break;
241
242 case 'p':
243 match ("parameter", gfc_match_parameter, ST_PARAMETER);
244 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
245 if (gfc_match_private (&st) == MATCH_YES)
246 return st;
247 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
248 if (gfc_match_public (&st) == MATCH_YES)
249 return st;
250 match ("protected", gfc_match_protected, ST_ATTR_DECL);
251 break;
252
253 case 'r':
254 break;
255
256 case 's':
257 match ("save", gfc_match_save, ST_ATTR_DECL);
258 break;
259
260 case 't':
261 match ("target", gfc_match_target, ST_ATTR_DECL);
262 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
263 break;
264
265 case 'u':
266 break;
267
268 case 'v':
269 match ("value", gfc_match_value, ST_ATTR_DECL);
270 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
271 break;
272
273 case 'w':
274 break;
275 }
276
277 /* This is not a specification statement. See if any of the matchers
278 has stored an error message of some sort. */
279
280 end_of_block:
281 gfc_clear_error ();
282 gfc_buffer_error (0);
283 gfc_current_locus = old_locus;
284
285 return ST_GET_FCN_CHARACTERISTICS;
286 }
287
288
289 /* This is the primary 'decode_statement'. */
290 static gfc_statement
291 decode_statement (void)
292 {
293 gfc_namespace *ns;
294 gfc_statement st;
295 locus old_locus;
296 match m;
297 char c;
298
299 gfc_enforce_clean_symbol_state ();
300
301 gfc_clear_error (); /* Clear any pending errors. */
302 gfc_clear_warning (); /* Clear any pending warnings. */
303
304 gfc_matching_function = false;
305
306 if (gfc_match_eos () == MATCH_YES)
307 return ST_NONE;
308
309 if (gfc_current_state () == COMP_FUNCTION
310 && gfc_current_block ()->result->ts.kind == -1)
311 return decode_specification_statement ();
312
313 old_locus = gfc_current_locus;
314
315 c = gfc_peek_ascii_char ();
316
317 if (c == 'u')
318 {
319 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
320 {
321 last_was_use_stmt = true;
322 return ST_USE;
323 }
324 else
325 undo_new_statement ();
326 }
327
328 if (last_was_use_stmt)
329 use_modules ();
330
331 /* Try matching a data declaration or function declaration. The
332 input "REALFUNCTIONA(N)" can mean several things in different
333 contexts, so it (and its relatives) get special treatment. */
334
335 if (gfc_current_state () == COMP_NONE
336 || gfc_current_state () == COMP_INTERFACE
337 || gfc_current_state () == COMP_CONTAINS)
338 {
339 gfc_matching_function = true;
340 m = gfc_match_function_decl ();
341 if (m == MATCH_YES)
342 return ST_FUNCTION;
343 else if (m == MATCH_ERROR)
344 reject_statement ();
345 else
346 gfc_undo_symbols ();
347 gfc_current_locus = old_locus;
348 }
349 gfc_matching_function = false;
350
351
352 /* Match statements whose error messages are meant to be overwritten
353 by something better. */
354
355 match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
356 match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
357 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
358
359 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
360 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
361
362 /* Try to match a subroutine statement, which has the same optional
363 prefixes that functions can have. */
364
365 if (gfc_match_subroutine () == MATCH_YES)
366 return ST_SUBROUTINE;
367 gfc_undo_symbols ();
368 gfc_current_locus = old_locus;
369
370 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
371 statements, which might begin with a block label. The match functions for
372 these statements are unusual in that their keyword is not seen before
373 the matcher is called. */
374
375 if (gfc_match_if (&st) == MATCH_YES)
376 return st;
377 gfc_undo_symbols ();
378 gfc_current_locus = old_locus;
379
380 if (gfc_match_where (&st) == MATCH_YES)
381 return st;
382 gfc_undo_symbols ();
383 gfc_current_locus = old_locus;
384
385 if (gfc_match_forall (&st) == MATCH_YES)
386 return st;
387 gfc_undo_symbols ();
388 gfc_current_locus = old_locus;
389
390 match (NULL, gfc_match_do, ST_DO);
391 match (NULL, gfc_match_block, ST_BLOCK);
392 match (NULL, gfc_match_associate, ST_ASSOCIATE);
393 match (NULL, gfc_match_critical, ST_CRITICAL);
394 match (NULL, gfc_match_select, ST_SELECT_CASE);
395
396 gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
397 match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
398 ns = gfc_current_ns;
399 gfc_current_ns = gfc_current_ns->parent;
400 gfc_free_namespace (ns);
401
402 /* General statement matching: Instead of testing every possible
403 statement, we eliminate most possibilities by peeking at the
404 first character. */
405
406 switch (c)
407 {
408 case 'a':
409 match ("abstract% interface", gfc_match_abstract_interface,
410 ST_INTERFACE);
411 match ("allocate", gfc_match_allocate, ST_ALLOCATE);
412 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
413 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
414 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
415 break;
416
417 case 'b':
418 match ("backspace", gfc_match_backspace, ST_BACKSPACE);
419 match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
420 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
421 break;
422
423 case 'c':
424 match ("call", gfc_match_call, ST_CALL);
425 match ("close", gfc_match_close, ST_CLOSE);
426 match ("continue", gfc_match_continue, ST_CONTINUE);
427 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
428 match ("cycle", gfc_match_cycle, ST_CYCLE);
429 match ("case", gfc_match_case, ST_CASE);
430 match ("common", gfc_match_common, ST_COMMON);
431 match ("contains", gfc_match_eos, ST_CONTAINS);
432 match ("class", gfc_match_class_is, ST_CLASS_IS);
433 match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
434 break;
435
436 case 'd':
437 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
438 match ("data", gfc_match_data, ST_DATA);
439 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
440 break;
441
442 case 'e':
443 match ("end file", gfc_match_endfile, ST_END_FILE);
444 match ("exit", gfc_match_exit, ST_EXIT);
445 match ("else", gfc_match_else, ST_ELSE);
446 match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
447 match ("else if", gfc_match_elseif, ST_ELSEIF);
448 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
449 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
450
451 if (gfc_match_end (&st) == MATCH_YES)
452 return st;
453
454 match ("entry% ", gfc_match_entry, ST_ENTRY);
455 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
456 match ("external", gfc_match_external, ST_ATTR_DECL);
457 break;
458
459 case 'f':
460 match ("final", gfc_match_final_decl, ST_FINAL);
461 match ("flush", gfc_match_flush, ST_FLUSH);
462 match ("format", gfc_match_format, ST_FORMAT);
463 break;
464
465 case 'g':
466 match ("generic", gfc_match_generic, ST_GENERIC);
467 match ("go to", gfc_match_goto, ST_GOTO);
468 break;
469
470 case 'i':
471 match ("inquire", gfc_match_inquire, ST_INQUIRE);
472 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
473 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
474 match ("import", gfc_match_import, ST_IMPORT);
475 match ("interface", gfc_match_interface, ST_INTERFACE);
476 match ("intent", gfc_match_intent, ST_ATTR_DECL);
477 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
478 break;
479
480 case 'l':
481 match ("lock", gfc_match_lock, ST_LOCK);
482 break;
483
484 case 'm':
485 match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
486 match ("module", gfc_match_module, ST_MODULE);
487 break;
488
489 case 'n':
490 match ("nullify", gfc_match_nullify, ST_NULLIFY);
491 match ("namelist", gfc_match_namelist, ST_NAMELIST);
492 break;
493
494 case 'o':
495 match ("open", gfc_match_open, ST_OPEN);
496 match ("optional", gfc_match_optional, ST_ATTR_DECL);
497 break;
498
499 case 'p':
500 match ("print", gfc_match_print, ST_WRITE);
501 match ("parameter", gfc_match_parameter, ST_PARAMETER);
502 match ("pause", gfc_match_pause, ST_PAUSE);
503 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
504 if (gfc_match_private (&st) == MATCH_YES)
505 return st;
506 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
507 match ("program", gfc_match_program, ST_PROGRAM);
508 if (gfc_match_public (&st) == MATCH_YES)
509 return st;
510 match ("protected", gfc_match_protected, ST_ATTR_DECL);
511 break;
512
513 case 'r':
514 match ("read", gfc_match_read, ST_READ);
515 match ("return", gfc_match_return, ST_RETURN);
516 match ("rewind", gfc_match_rewind, ST_REWIND);
517 break;
518
519 case 's':
520 match ("sequence", gfc_match_eos, ST_SEQUENCE);
521 match ("stop", gfc_match_stop, ST_STOP);
522 match ("save", gfc_match_save, ST_ATTR_DECL);
523 match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
524 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
525 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
526 break;
527
528 case 't':
529 match ("target", gfc_match_target, ST_ATTR_DECL);
530 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
531 match ("type is", gfc_match_type_is, ST_TYPE_IS);
532 break;
533
534 case 'u':
535 match ("unlock", gfc_match_unlock, ST_UNLOCK);
536 break;
537
538 case 'v':
539 match ("value", gfc_match_value, ST_ATTR_DECL);
540 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
541 break;
542
543 case 'w':
544 match ("wait", gfc_match_wait, ST_WAIT);
545 match ("write", gfc_match_write, ST_WRITE);
546 break;
547 }
548
549 /* All else has failed, so give up. See if any of the matchers has
550 stored an error message of some sort. */
551
552 if (gfc_error_check () == 0)
553 gfc_error_now_2 ("Unclassifiable statement at %C");
554
555 reject_statement ();
556
557 gfc_error_recovery ();
558
559 return ST_NONE;
560 }
561
562 /* Like match, but set a flag simd_matched if keyword matched. */
563 #define matchs(keyword, subr, st) \
564 do { \
565 if (match_word_omp_simd (keyword, subr, &old_locus, \
566 &simd_matched) == MATCH_YES) \
567 return st; \
568 else \
569 undo_new_statement (); \
570 } while (0);
571
572 /* Like match, but don't match anything if not -fopenmp. */
573 #define matcho(keyword, subr, st) \
574 do { \
575 if (!gfc_option.gfc_flag_openmp) \
576 ; \
577 else if (match_word (keyword, subr, &old_locus) \
578 == MATCH_YES) \
579 return st; \
580 else \
581 undo_new_statement (); \
582 } while (0);
583
584 static gfc_statement
585 decode_omp_directive (void)
586 {
587 locus old_locus;
588 char c;
589 bool simd_matched = false;
590
591 gfc_enforce_clean_symbol_state ();
592
593 gfc_clear_error (); /* Clear any pending errors. */
594 gfc_clear_warning (); /* Clear any pending warnings. */
595
596 if (gfc_pure (NULL))
597 {
598 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
599 "or ELEMENTAL procedures");
600 gfc_error_recovery ();
601 return ST_NONE;
602 }
603
604 gfc_unset_implicit_pure (NULL);
605
606 old_locus = gfc_current_locus;
607
608 /* General OpenMP directive matching: Instead of testing every possible
609 statement, we eliminate most possibilities by peeking at the
610 first character. */
611
612 c = gfc_peek_ascii_char ();
613
614 /* match is for directives that should be recognized only if
615 -fopenmp, matchs for directives that should be recognized
616 if either -fopenmp or -fopenmp-simd. */
617 switch (c)
618 {
619 case 'a':
620 matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
621 break;
622 case 'b':
623 matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
624 break;
625 case 'c':
626 matcho ("cancellation% point", gfc_match_omp_cancellation_point,
627 ST_OMP_CANCELLATION_POINT);
628 matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
629 matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
630 break;
631 case 'd':
632 matchs ("declare reduction", gfc_match_omp_declare_reduction,
633 ST_OMP_DECLARE_REDUCTION);
634 matchs ("declare simd", gfc_match_omp_declare_simd,
635 ST_OMP_DECLARE_SIMD);
636 matcho ("declare target", gfc_match_omp_declare_target,
637 ST_OMP_DECLARE_TARGET);
638 matchs ("distribute parallel do simd",
639 gfc_match_omp_distribute_parallel_do_simd,
640 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
641 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
642 ST_OMP_DISTRIBUTE_PARALLEL_DO);
643 matchs ("distribute simd", gfc_match_omp_distribute_simd,
644 ST_OMP_DISTRIBUTE_SIMD);
645 matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
646 matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
647 matcho ("do", gfc_match_omp_do, ST_OMP_DO);
648 break;
649 case 'e':
650 matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
651 matcho ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
652 matchs ("end distribute parallel do simd", gfc_match_omp_eos,
653 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
654 matcho ("end distribute parallel do", gfc_match_omp_eos,
655 ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
656 matchs ("end distribute simd", gfc_match_omp_eos,
657 ST_OMP_END_DISTRIBUTE_SIMD);
658 matcho ("end distribute", gfc_match_omp_eos, ST_OMP_END_DISTRIBUTE);
659 matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
660 matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
661 matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
662 matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
663 matcho ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
664 matchs ("end parallel do simd", gfc_match_omp_eos,
665 ST_OMP_END_PARALLEL_DO_SIMD);
666 matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
667 matcho ("end parallel sections", gfc_match_omp_eos,
668 ST_OMP_END_PARALLEL_SECTIONS);
669 matcho ("end parallel workshare", gfc_match_omp_eos,
670 ST_OMP_END_PARALLEL_WORKSHARE);
671 matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
672 matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
673 matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
674 matcho ("end target data", gfc_match_omp_eos, ST_OMP_END_TARGET_DATA);
675 matchs ("end target teams distribute parallel do simd",
676 gfc_match_omp_eos,
677 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
678 matcho ("end target teams distribute parallel do", gfc_match_omp_eos,
679 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
680 matchs ("end target teams distribute simd", gfc_match_omp_eos,
681 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
682 matcho ("end target teams distribute", gfc_match_omp_eos,
683 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
684 matcho ("end target teams", gfc_match_omp_eos, ST_OMP_END_TARGET_TEAMS);
685 matcho ("end target", gfc_match_omp_eos, ST_OMP_END_TARGET);
686 matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
687 matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
688 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos,
689 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
690 matcho ("end teams distribute parallel do", gfc_match_omp_eos,
691 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
692 matchs ("end teams distribute simd", gfc_match_omp_eos,
693 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
694 matcho ("end teams distribute", gfc_match_omp_eos,
695 ST_OMP_END_TEAMS_DISTRIBUTE);
696 matcho ("end teams", gfc_match_omp_eos, ST_OMP_END_TEAMS);
697 matcho ("end workshare", gfc_match_omp_end_nowait,
698 ST_OMP_END_WORKSHARE);
699 break;
700 case 'f':
701 matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
702 break;
703 case 'm':
704 matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
705 break;
706 case 'o':
707 matcho ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
708 break;
709 case 'p':
710 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
711 ST_OMP_PARALLEL_DO_SIMD);
712 matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
713 matcho ("parallel sections", gfc_match_omp_parallel_sections,
714 ST_OMP_PARALLEL_SECTIONS);
715 matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
716 ST_OMP_PARALLEL_WORKSHARE);
717 matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
718 break;
719 case 's':
720 matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
721 matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION);
722 matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
723 matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
724 break;
725 case 't':
726 matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
727 matchs ("target teams distribute parallel do simd",
728 gfc_match_omp_target_teams_distribute_parallel_do_simd,
729 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
730 matcho ("target teams distribute parallel do",
731 gfc_match_omp_target_teams_distribute_parallel_do,
732 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
733 matchs ("target teams distribute simd",
734 gfc_match_omp_target_teams_distribute_simd,
735 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
736 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
737 ST_OMP_TARGET_TEAMS_DISTRIBUTE);
738 matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
739 matcho ("target update", gfc_match_omp_target_update,
740 ST_OMP_TARGET_UPDATE);
741 matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
742 matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
743 matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
744 matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
745 matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
746 matchs ("teams distribute parallel do simd",
747 gfc_match_omp_teams_distribute_parallel_do_simd,
748 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
749 matcho ("teams distribute parallel do",
750 gfc_match_omp_teams_distribute_parallel_do,
751 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
752 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
753 ST_OMP_TEAMS_DISTRIBUTE_SIMD);
754 matcho ("teams distribute", gfc_match_omp_teams_distribute,
755 ST_OMP_TEAMS_DISTRIBUTE);
756 matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
757 matcho ("threadprivate", gfc_match_omp_threadprivate,
758 ST_OMP_THREADPRIVATE);
759 break;
760 case 'w':
761 matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
762 break;
763 }
764
765 /* All else has failed, so give up. See if any of the matchers has
766 stored an error message of some sort. Don't error out if
767 not -fopenmp and simd_matched is false, i.e. if a directive other
768 than one marked with match has been seen. */
769
770 if (gfc_option.gfc_flag_openmp || simd_matched)
771 {
772 if (gfc_error_check () == 0)
773 gfc_error_now ("Unclassifiable OpenMP directive at %C");
774 }
775
776 reject_statement ();
777
778 gfc_error_recovery ();
779
780 return ST_NONE;
781 }
782
783 static gfc_statement
784 decode_gcc_attribute (void)
785 {
786 locus old_locus;
787
788 gfc_enforce_clean_symbol_state ();
789
790 gfc_clear_error (); /* Clear any pending errors. */
791 gfc_clear_warning (); /* Clear any pending warnings. */
792 old_locus = gfc_current_locus;
793
794 match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
795
796 /* All else has failed, so give up. See if any of the matchers has
797 stored an error message of some sort. */
798
799 if (gfc_error_check () == 0)
800 gfc_error_now_2 ("Unclassifiable GCC directive at %C");
801
802 reject_statement ();
803
804 gfc_error_recovery ();
805
806 return ST_NONE;
807 }
808
809 #undef match
810
811
812 /* Get the next statement in free form source. */
813
814 static gfc_statement
815 next_free (void)
816 {
817 match m;
818 int i, cnt, at_bol;
819 char c;
820
821 at_bol = gfc_at_bol ();
822 gfc_gobble_whitespace ();
823
824 c = gfc_peek_ascii_char ();
825
826 if (ISDIGIT (c))
827 {
828 char d;
829
830 /* Found a statement label? */
831 m = gfc_match_st_label (&gfc_statement_label);
832
833 d = gfc_peek_ascii_char ();
834 if (m != MATCH_YES || !gfc_is_whitespace (d))
835 {
836 gfc_match_small_literal_int (&i, &cnt);
837
838 if (cnt > 5)
839 gfc_error_now_2 ("Too many digits in statement label at %C");
840
841 if (i == 0)
842 gfc_error_now_2 ("Zero is not a valid statement label at %C");
843
844 do
845 c = gfc_next_ascii_char ();
846 while (ISDIGIT(c));
847
848 if (!gfc_is_whitespace (c))
849 gfc_error_now_2 ("Non-numeric character in statement label at %C");
850
851 return ST_NONE;
852 }
853 else
854 {
855 label_locus = gfc_current_locus;
856
857 gfc_gobble_whitespace ();
858
859 if (at_bol && gfc_peek_ascii_char () == ';')
860 {
861 gfc_error_now_2 ("Semicolon at %C needs to be preceded by "
862 "statement");
863 gfc_next_ascii_char (); /* Eat up the semicolon. */
864 return ST_NONE;
865 }
866
867 if (gfc_match_eos () == MATCH_YES)
868 {
869 gfc_warning_now ("Ignoring statement label in empty statement "
870 "at %L", &label_locus);
871 gfc_free_st_label (gfc_statement_label);
872 gfc_statement_label = NULL;
873 return ST_NONE;
874 }
875 }
876 }
877 else if (c == '!')
878 {
879 /* Comments have already been skipped by the time we get here,
880 except for GCC attributes and OpenMP directives. */
881
882 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
883 c = gfc_peek_ascii_char ();
884
885 if (c == 'g')
886 {
887 int i;
888
889 c = gfc_next_ascii_char ();
890 for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
891 gcc_assert (c == "gcc$"[i]);
892
893 gfc_gobble_whitespace ();
894 return decode_gcc_attribute ();
895
896 }
897 else if (c == '$'
898 && (gfc_option.gfc_flag_openmp
899 || gfc_option.gfc_flag_openmp_simd))
900 {
901 int i;
902
903 c = gfc_next_ascii_char ();
904 for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
905 gcc_assert (c == "$omp"[i]);
906
907 gcc_assert (c == ' ' || c == '\t');
908 gfc_gobble_whitespace ();
909 if (last_was_use_stmt)
910 use_modules ();
911 return decode_omp_directive ();
912 }
913
914 gcc_unreachable ();
915 }
916
917 if (at_bol && c == ';')
918 {
919 if (!(gfc_option.allow_std & GFC_STD_F2008))
920 gfc_error_now_2 ("Fortran 2008: Semicolon at %C without preceding "
921 "statement");
922 gfc_next_ascii_char (); /* Eat up the semicolon. */
923 return ST_NONE;
924 }
925
926 return decode_statement ();
927 }
928
929
930 /* Get the next statement in fixed-form source. */
931
932 static gfc_statement
933 next_fixed (void)
934 {
935 int label, digit_flag, i;
936 locus loc;
937 gfc_char_t c;
938
939 if (!gfc_at_bol ())
940 return decode_statement ();
941
942 /* Skip past the current label field, parsing a statement label if
943 one is there. This is a weird number parser, since the number is
944 contained within five columns and can have any kind of embedded
945 spaces. We also check for characters that make the rest of the
946 line a comment. */
947
948 label = 0;
949 digit_flag = 0;
950
951 for (i = 0; i < 5; i++)
952 {
953 c = gfc_next_char_literal (NONSTRING);
954
955 switch (c)
956 {
957 case ' ':
958 break;
959
960 case '0':
961 case '1':
962 case '2':
963 case '3':
964 case '4':
965 case '5':
966 case '6':
967 case '7':
968 case '8':
969 case '9':
970 label = label * 10 + ((unsigned char) c - '0');
971 label_locus = gfc_current_locus;
972 digit_flag = 1;
973 break;
974
975 /* Comments have already been skipped by the time we get
976 here, except for GCC attributes and OpenMP directives. */
977
978 case '*':
979 c = gfc_next_char_literal (NONSTRING);
980
981 if (TOLOWER (c) == 'g')
982 {
983 for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
984 gcc_assert (TOLOWER (c) == "gcc$"[i]);
985
986 return decode_gcc_attribute ();
987 }
988 else if (c == '$'
989 && (gfc_option.gfc_flag_openmp
990 || gfc_option.gfc_flag_openmp_simd))
991 {
992 for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
993 gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
994
995 if (c != ' ' && c != '0')
996 {
997 gfc_buffer_error (0);
998 gfc_error ("Bad continuation line at %C");
999 return ST_NONE;
1000 }
1001 if (last_was_use_stmt)
1002 use_modules ();
1003 return decode_omp_directive ();
1004 }
1005 /* FALLTHROUGH */
1006
1007 /* Comments have already been skipped by the time we get
1008 here so don't bother checking for them. */
1009
1010 default:
1011 gfc_buffer_error (0);
1012 gfc_error ("Non-numeric character in statement label at %C");
1013 return ST_NONE;
1014 }
1015 }
1016
1017 if (digit_flag)
1018 {
1019 if (label == 0)
1020 gfc_warning_now_2 ("Zero is not a valid statement label at %C");
1021 else
1022 {
1023 /* We've found a valid statement label. */
1024 gfc_statement_label = gfc_get_st_label (label);
1025 }
1026 }
1027
1028 /* Since this line starts a statement, it cannot be a continuation
1029 of a previous statement. If we see something here besides a
1030 space or zero, it must be a bad continuation line. */
1031
1032 c = gfc_next_char_literal (NONSTRING);
1033 if (c == '\n')
1034 goto blank_line;
1035
1036 if (c != ' ' && c != '0')
1037 {
1038 gfc_buffer_error (0);
1039 gfc_error ("Bad continuation line at %C");
1040 return ST_NONE;
1041 }
1042
1043 /* Now that we've taken care of the statement label columns, we have
1044 to make sure that the first nonblank character is not a '!'. If
1045 it is, the rest of the line is a comment. */
1046
1047 do
1048 {
1049 loc = gfc_current_locus;
1050 c = gfc_next_char_literal (NONSTRING);
1051 }
1052 while (gfc_is_whitespace (c));
1053
1054 if (c == '!')
1055 goto blank_line;
1056 gfc_current_locus = loc;
1057
1058 if (c == ';')
1059 {
1060 if (digit_flag)
1061 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1062 else if (!(gfc_option.allow_std & GFC_STD_F2008))
1063 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1064 "statement");
1065 return ST_NONE;
1066 }
1067
1068 if (gfc_match_eos () == MATCH_YES)
1069 goto blank_line;
1070
1071 /* At this point, we've got a nonblank statement to parse. */
1072 return decode_statement ();
1073
1074 blank_line:
1075 if (digit_flag)
1076 gfc_warning_now ("Ignoring statement label in empty statement at %L",
1077 &label_locus);
1078
1079 gfc_current_locus.lb->truncated = 0;
1080 gfc_advance_line ();
1081 return ST_NONE;
1082 }
1083
1084
1085 /* Return the next non-ST_NONE statement to the caller. We also worry
1086 about including files and the ends of include files at this stage. */
1087
1088 static gfc_statement
1089 next_statement (void)
1090 {
1091 gfc_statement st;
1092 locus old_locus;
1093
1094 gfc_enforce_clean_symbol_state ();
1095
1096 gfc_new_block = NULL;
1097
1098 gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
1099 gfc_current_ns->old_equiv = gfc_current_ns->equiv;
1100 for (;;)
1101 {
1102 gfc_statement_label = NULL;
1103 gfc_buffer_error (1);
1104
1105 if (gfc_at_eol ())
1106 gfc_advance_line ();
1107
1108 gfc_skip_comments ();
1109
1110 if (gfc_at_end ())
1111 {
1112 st = ST_NONE;
1113 break;
1114 }
1115
1116 if (gfc_define_undef_line ())
1117 continue;
1118
1119 old_locus = gfc_current_locus;
1120
1121 st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
1122
1123 if (st != ST_NONE)
1124 break;
1125 }
1126
1127 gfc_buffer_error (0);
1128
1129 if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
1130 {
1131 gfc_free_st_label (gfc_statement_label);
1132 gfc_statement_label = NULL;
1133 gfc_current_locus = old_locus;
1134 }
1135
1136 if (st != ST_NONE)
1137 check_statement_label (st);
1138
1139 return st;
1140 }
1141
1142
1143 /****************************** Parser ***********************************/
1144
1145 /* The parser subroutines are of type 'try' that fail if the file ends
1146 unexpectedly. */
1147
1148 /* Macros that expand to case-labels for various classes of
1149 statements. Start with executable statements that directly do
1150 things. */
1151
1152 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1153 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1154 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1155 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1156 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1157 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1158 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1159 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1160 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1161 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1162 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1163 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
1164
1165 /* Statements that mark other executable statements. */
1166
1167 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1168 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1169 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1170 case ST_OMP_PARALLEL: \
1171 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1172 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1173 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1174 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1175 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1176 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1177 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1178 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1179 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1180 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1181 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1182 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1183 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1184 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1185 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1186 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1187 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1188 case ST_CRITICAL
1189
1190 /* Declaration statements */
1191
1192 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1193 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1194 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1195 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1196 case ST_OMP_DECLARE_TARGET
1197
1198 /* Block end statements. Errors associated with interchanging these
1199 are detected in gfc_match_end(). */
1200
1201 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1202 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1203 case ST_END_BLOCK: case ST_END_ASSOCIATE
1204
1205
1206 /* Push a new state onto the stack. */
1207
1208 static void
1209 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
1210 {
1211 p->state = new_state;
1212 p->previous = gfc_state_stack;
1213 p->sym = sym;
1214 p->head = p->tail = NULL;
1215 p->do_variable = NULL;
1216
1217 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1218 construct statement was accepted right before pushing the state. Thus,
1219 the construct's gfc_code is available as tail of the parent state. */
1220 gcc_assert (gfc_state_stack);
1221 p->construct = gfc_state_stack->tail;
1222
1223 gfc_state_stack = p;
1224 }
1225
1226
1227 /* Pop the current state. */
1228 static void
1229 pop_state (void)
1230 {
1231 gfc_state_stack = gfc_state_stack->previous;
1232 }
1233
1234
1235 /* Try to find the given state in the state stack. */
1236
1237 bool
1238 gfc_find_state (gfc_compile_state state)
1239 {
1240 gfc_state_data *p;
1241
1242 for (p = gfc_state_stack; p; p = p->previous)
1243 if (p->state == state)
1244 break;
1245
1246 return (p == NULL) ? false : true;
1247 }
1248
1249
1250 /* Starts a new level in the statement list. */
1251
1252 static gfc_code *
1253 new_level (gfc_code *q)
1254 {
1255 gfc_code *p;
1256
1257 p = q->block = gfc_get_code (EXEC_NOP);
1258
1259 gfc_state_stack->head = gfc_state_stack->tail = p;
1260
1261 return p;
1262 }
1263
1264
1265 /* Add the current new_st code structure and adds it to the current
1266 program unit. As a side-effect, it zeroes the new_st. */
1267
1268 static gfc_code *
1269 add_statement (void)
1270 {
1271 gfc_code *p;
1272
1273 p = XCNEW (gfc_code);
1274 *p = new_st;
1275
1276 p->loc = gfc_current_locus;
1277
1278 if (gfc_state_stack->head == NULL)
1279 gfc_state_stack->head = p;
1280 else
1281 gfc_state_stack->tail->next = p;
1282
1283 while (p->next != NULL)
1284 p = p->next;
1285
1286 gfc_state_stack->tail = p;
1287
1288 gfc_clear_new_st ();
1289
1290 return p;
1291 }
1292
1293
1294 /* Frees everything associated with the current statement. */
1295
1296 static void
1297 undo_new_statement (void)
1298 {
1299 gfc_free_statements (new_st.block);
1300 gfc_free_statements (new_st.next);
1301 gfc_free_statement (&new_st);
1302 gfc_clear_new_st ();
1303 }
1304
1305
1306 /* If the current statement has a statement label, make sure that it
1307 is allowed to, or should have one. */
1308
1309 static void
1310 check_statement_label (gfc_statement st)
1311 {
1312 gfc_sl_type type;
1313
1314 if (gfc_statement_label == NULL)
1315 {
1316 if (st == ST_FORMAT)
1317 gfc_error ("FORMAT statement at %L does not have a statement label",
1318 &new_st.loc);
1319 return;
1320 }
1321
1322 switch (st)
1323 {
1324 case ST_END_PROGRAM:
1325 case ST_END_FUNCTION:
1326 case ST_END_SUBROUTINE:
1327 case ST_ENDDO:
1328 case ST_ENDIF:
1329 case ST_END_SELECT:
1330 case ST_END_CRITICAL:
1331 case ST_END_BLOCK:
1332 case ST_END_ASSOCIATE:
1333 case_executable:
1334 case_exec_markers:
1335 if (st == ST_ENDDO || st == ST_CONTINUE)
1336 type = ST_LABEL_DO_TARGET;
1337 else
1338 type = ST_LABEL_TARGET;
1339 break;
1340
1341 case ST_FORMAT:
1342 type = ST_LABEL_FORMAT;
1343 break;
1344
1345 /* Statement labels are not restricted from appearing on a
1346 particular line. However, there are plenty of situations
1347 where the resulting label can't be referenced. */
1348
1349 default:
1350 type = ST_LABEL_BAD_TARGET;
1351 break;
1352 }
1353
1354 gfc_define_st_label (gfc_statement_label, type, &label_locus);
1355
1356 new_st.here = gfc_statement_label;
1357 }
1358
1359
1360 /* Figures out what the enclosing program unit is. This will be a
1361 function, subroutine, program, block data or module. */
1362
1363 gfc_state_data *
1364 gfc_enclosing_unit (gfc_compile_state * result)
1365 {
1366 gfc_state_data *p;
1367
1368 for (p = gfc_state_stack; p; p = p->previous)
1369 if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1370 || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1371 || p->state == COMP_PROGRAM)
1372 {
1373
1374 if (result != NULL)
1375 *result = p->state;
1376 return p;
1377 }
1378
1379 if (result != NULL)
1380 *result = COMP_PROGRAM;
1381 return NULL;
1382 }
1383
1384
1385 /* Translate a statement enum to a string. */
1386
1387 const char *
1388 gfc_ascii_statement (gfc_statement st)
1389 {
1390 const char *p;
1391
1392 switch (st)
1393 {
1394 case ST_ARITHMETIC_IF:
1395 p = _("arithmetic IF");
1396 break;
1397 case ST_ALLOCATE:
1398 p = "ALLOCATE";
1399 break;
1400 case ST_ASSOCIATE:
1401 p = "ASSOCIATE";
1402 break;
1403 case ST_ATTR_DECL:
1404 p = _("attribute declaration");
1405 break;
1406 case ST_BACKSPACE:
1407 p = "BACKSPACE";
1408 break;
1409 case ST_BLOCK:
1410 p = "BLOCK";
1411 break;
1412 case ST_BLOCK_DATA:
1413 p = "BLOCK DATA";
1414 break;
1415 case ST_CALL:
1416 p = "CALL";
1417 break;
1418 case ST_CASE:
1419 p = "CASE";
1420 break;
1421 case ST_CLOSE:
1422 p = "CLOSE";
1423 break;
1424 case ST_COMMON:
1425 p = "COMMON";
1426 break;
1427 case ST_CONTINUE:
1428 p = "CONTINUE";
1429 break;
1430 case ST_CONTAINS:
1431 p = "CONTAINS";
1432 break;
1433 case ST_CRITICAL:
1434 p = "CRITICAL";
1435 break;
1436 case ST_CYCLE:
1437 p = "CYCLE";
1438 break;
1439 case ST_DATA_DECL:
1440 p = _("data declaration");
1441 break;
1442 case ST_DATA:
1443 p = "DATA";
1444 break;
1445 case ST_DEALLOCATE:
1446 p = "DEALLOCATE";
1447 break;
1448 case ST_DERIVED_DECL:
1449 p = _("derived type declaration");
1450 break;
1451 case ST_DO:
1452 p = "DO";
1453 break;
1454 case ST_ELSE:
1455 p = "ELSE";
1456 break;
1457 case ST_ELSEIF:
1458 p = "ELSE IF";
1459 break;
1460 case ST_ELSEWHERE:
1461 p = "ELSEWHERE";
1462 break;
1463 case ST_END_ASSOCIATE:
1464 p = "END ASSOCIATE";
1465 break;
1466 case ST_END_BLOCK:
1467 p = "END BLOCK";
1468 break;
1469 case ST_END_BLOCK_DATA:
1470 p = "END BLOCK DATA";
1471 break;
1472 case ST_END_CRITICAL:
1473 p = "END CRITICAL";
1474 break;
1475 case ST_ENDDO:
1476 p = "END DO";
1477 break;
1478 case ST_END_FILE:
1479 p = "END FILE";
1480 break;
1481 case ST_END_FORALL:
1482 p = "END FORALL";
1483 break;
1484 case ST_END_FUNCTION:
1485 p = "END FUNCTION";
1486 break;
1487 case ST_ENDIF:
1488 p = "END IF";
1489 break;
1490 case ST_END_INTERFACE:
1491 p = "END INTERFACE";
1492 break;
1493 case ST_END_MODULE:
1494 p = "END MODULE";
1495 break;
1496 case ST_END_PROGRAM:
1497 p = "END PROGRAM";
1498 break;
1499 case ST_END_SELECT:
1500 p = "END SELECT";
1501 break;
1502 case ST_END_SUBROUTINE:
1503 p = "END SUBROUTINE";
1504 break;
1505 case ST_END_WHERE:
1506 p = "END WHERE";
1507 break;
1508 case ST_END_TYPE:
1509 p = "END TYPE";
1510 break;
1511 case ST_ENTRY:
1512 p = "ENTRY";
1513 break;
1514 case ST_EQUIVALENCE:
1515 p = "EQUIVALENCE";
1516 break;
1517 case ST_ERROR_STOP:
1518 p = "ERROR STOP";
1519 break;
1520 case ST_EXIT:
1521 p = "EXIT";
1522 break;
1523 case ST_FLUSH:
1524 p = "FLUSH";
1525 break;
1526 case ST_FORALL_BLOCK: /* Fall through */
1527 case ST_FORALL:
1528 p = "FORALL";
1529 break;
1530 case ST_FORMAT:
1531 p = "FORMAT";
1532 break;
1533 case ST_FUNCTION:
1534 p = "FUNCTION";
1535 break;
1536 case ST_GENERIC:
1537 p = "GENERIC";
1538 break;
1539 case ST_GOTO:
1540 p = "GOTO";
1541 break;
1542 case ST_IF_BLOCK:
1543 p = _("block IF");
1544 break;
1545 case ST_IMPLICIT:
1546 p = "IMPLICIT";
1547 break;
1548 case ST_IMPLICIT_NONE:
1549 p = "IMPLICIT NONE";
1550 break;
1551 case ST_IMPLIED_ENDDO:
1552 p = _("implied END DO");
1553 break;
1554 case ST_IMPORT:
1555 p = "IMPORT";
1556 break;
1557 case ST_INQUIRE:
1558 p = "INQUIRE";
1559 break;
1560 case ST_INTERFACE:
1561 p = "INTERFACE";
1562 break;
1563 case ST_LOCK:
1564 p = "LOCK";
1565 break;
1566 case ST_PARAMETER:
1567 p = "PARAMETER";
1568 break;
1569 case ST_PRIVATE:
1570 p = "PRIVATE";
1571 break;
1572 case ST_PUBLIC:
1573 p = "PUBLIC";
1574 break;
1575 case ST_MODULE:
1576 p = "MODULE";
1577 break;
1578 case ST_PAUSE:
1579 p = "PAUSE";
1580 break;
1581 case ST_MODULE_PROC:
1582 p = "MODULE PROCEDURE";
1583 break;
1584 case ST_NAMELIST:
1585 p = "NAMELIST";
1586 break;
1587 case ST_NULLIFY:
1588 p = "NULLIFY";
1589 break;
1590 case ST_OPEN:
1591 p = "OPEN";
1592 break;
1593 case ST_PROGRAM:
1594 p = "PROGRAM";
1595 break;
1596 case ST_PROCEDURE:
1597 p = "PROCEDURE";
1598 break;
1599 case ST_READ:
1600 p = "READ";
1601 break;
1602 case ST_RETURN:
1603 p = "RETURN";
1604 break;
1605 case ST_REWIND:
1606 p = "REWIND";
1607 break;
1608 case ST_STOP:
1609 p = "STOP";
1610 break;
1611 case ST_SYNC_ALL:
1612 p = "SYNC ALL";
1613 break;
1614 case ST_SYNC_IMAGES:
1615 p = "SYNC IMAGES";
1616 break;
1617 case ST_SYNC_MEMORY:
1618 p = "SYNC MEMORY";
1619 break;
1620 case ST_SUBROUTINE:
1621 p = "SUBROUTINE";
1622 break;
1623 case ST_TYPE:
1624 p = "TYPE";
1625 break;
1626 case ST_UNLOCK:
1627 p = "UNLOCK";
1628 break;
1629 case ST_USE:
1630 p = "USE";
1631 break;
1632 case ST_WHERE_BLOCK: /* Fall through */
1633 case ST_WHERE:
1634 p = "WHERE";
1635 break;
1636 case ST_WAIT:
1637 p = "WAIT";
1638 break;
1639 case ST_WRITE:
1640 p = "WRITE";
1641 break;
1642 case ST_ASSIGNMENT:
1643 p = _("assignment");
1644 break;
1645 case ST_POINTER_ASSIGNMENT:
1646 p = _("pointer assignment");
1647 break;
1648 case ST_SELECT_CASE:
1649 p = "SELECT CASE";
1650 break;
1651 case ST_SELECT_TYPE:
1652 p = "SELECT TYPE";
1653 break;
1654 case ST_TYPE_IS:
1655 p = "TYPE IS";
1656 break;
1657 case ST_CLASS_IS:
1658 p = "CLASS IS";
1659 break;
1660 case ST_SEQUENCE:
1661 p = "SEQUENCE";
1662 break;
1663 case ST_SIMPLE_IF:
1664 p = _("simple IF");
1665 break;
1666 case ST_STATEMENT_FUNCTION:
1667 p = "STATEMENT FUNCTION";
1668 break;
1669 case ST_LABEL_ASSIGNMENT:
1670 p = "LABEL ASSIGNMENT";
1671 break;
1672 case ST_ENUM:
1673 p = "ENUM DEFINITION";
1674 break;
1675 case ST_ENUMERATOR:
1676 p = "ENUMERATOR DEFINITION";
1677 break;
1678 case ST_END_ENUM:
1679 p = "END ENUM";
1680 break;
1681 case ST_OMP_ATOMIC:
1682 p = "!$OMP ATOMIC";
1683 break;
1684 case ST_OMP_BARRIER:
1685 p = "!$OMP BARRIER";
1686 break;
1687 case ST_OMP_CANCEL:
1688 p = "!$OMP CANCEL";
1689 break;
1690 case ST_OMP_CANCELLATION_POINT:
1691 p = "!$OMP CANCELLATION POINT";
1692 break;
1693 case ST_OMP_CRITICAL:
1694 p = "!$OMP CRITICAL";
1695 break;
1696 case ST_OMP_DECLARE_REDUCTION:
1697 p = "!$OMP DECLARE REDUCTION";
1698 break;
1699 case ST_OMP_DECLARE_SIMD:
1700 p = "!$OMP DECLARE SIMD";
1701 break;
1702 case ST_OMP_DECLARE_TARGET:
1703 p = "!$OMP DECLARE TARGET";
1704 break;
1705 case ST_OMP_DISTRIBUTE:
1706 p = "!$OMP DISTRIBUTE";
1707 break;
1708 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
1709 p = "!$OMP DISTRIBUTE PARALLEL DO";
1710 break;
1711 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
1712 p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1713 break;
1714 case ST_OMP_DISTRIBUTE_SIMD:
1715 p = "!$OMP DISTRIBUTE SIMD";
1716 break;
1717 case ST_OMP_DO:
1718 p = "!$OMP DO";
1719 break;
1720 case ST_OMP_DO_SIMD:
1721 p = "!$OMP DO SIMD";
1722 break;
1723 case ST_OMP_END_ATOMIC:
1724 p = "!$OMP END ATOMIC";
1725 break;
1726 case ST_OMP_END_CRITICAL:
1727 p = "!$OMP END CRITICAL";
1728 break;
1729 case ST_OMP_END_DISTRIBUTE:
1730 p = "!$OMP END DISTRIBUTE";
1731 break;
1732 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
1733 p = "!$OMP END DISTRIBUTE PARALLEL DO";
1734 break;
1735 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
1736 p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1737 break;
1738 case ST_OMP_END_DISTRIBUTE_SIMD:
1739 p = "!$OMP END DISTRIBUTE SIMD";
1740 break;
1741 case ST_OMP_END_DO:
1742 p = "!$OMP END DO";
1743 break;
1744 case ST_OMP_END_DO_SIMD:
1745 p = "!$OMP END DO SIMD";
1746 break;
1747 case ST_OMP_END_SIMD:
1748 p = "!$OMP END SIMD";
1749 break;
1750 case ST_OMP_END_MASTER:
1751 p = "!$OMP END MASTER";
1752 break;
1753 case ST_OMP_END_ORDERED:
1754 p = "!$OMP END ORDERED";
1755 break;
1756 case ST_OMP_END_PARALLEL:
1757 p = "!$OMP END PARALLEL";
1758 break;
1759 case ST_OMP_END_PARALLEL_DO:
1760 p = "!$OMP END PARALLEL DO";
1761 break;
1762 case ST_OMP_END_PARALLEL_DO_SIMD:
1763 p = "!$OMP END PARALLEL DO SIMD";
1764 break;
1765 case ST_OMP_END_PARALLEL_SECTIONS:
1766 p = "!$OMP END PARALLEL SECTIONS";
1767 break;
1768 case ST_OMP_END_PARALLEL_WORKSHARE:
1769 p = "!$OMP END PARALLEL WORKSHARE";
1770 break;
1771 case ST_OMP_END_SECTIONS:
1772 p = "!$OMP END SECTIONS";
1773 break;
1774 case ST_OMP_END_SINGLE:
1775 p = "!$OMP END SINGLE";
1776 break;
1777 case ST_OMP_END_TASK:
1778 p = "!$OMP END TASK";
1779 break;
1780 case ST_OMP_END_TARGET:
1781 p = "!$OMP END TARGET";
1782 break;
1783 case ST_OMP_END_TARGET_DATA:
1784 p = "!$OMP END TARGET DATA";
1785 break;
1786 case ST_OMP_END_TARGET_TEAMS:
1787 p = "!$OMP END TARGET TEAMS";
1788 break;
1789 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
1790 p = "!$OMP END TARGET TEAMS DISTRIBUTE";
1791 break;
1792 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1793 p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
1794 break;
1795 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1796 p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
1797 break;
1798 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
1799 p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
1800 break;
1801 case ST_OMP_END_TASKGROUP:
1802 p = "!$OMP END TASKGROUP";
1803 break;
1804 case ST_OMP_END_TEAMS:
1805 p = "!$OMP END TEAMS";
1806 break;
1807 case ST_OMP_END_TEAMS_DISTRIBUTE:
1808 p = "!$OMP END TEAMS DISTRIBUTE";
1809 break;
1810 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
1811 p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
1812 break;
1813 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1814 p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
1815 break;
1816 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
1817 p = "!$OMP END TEAMS DISTRIBUTE SIMD";
1818 break;
1819 case ST_OMP_END_WORKSHARE:
1820 p = "!$OMP END WORKSHARE";
1821 break;
1822 case ST_OMP_FLUSH:
1823 p = "!$OMP FLUSH";
1824 break;
1825 case ST_OMP_MASTER:
1826 p = "!$OMP MASTER";
1827 break;
1828 case ST_OMP_ORDERED:
1829 p = "!$OMP ORDERED";
1830 break;
1831 case ST_OMP_PARALLEL:
1832 p = "!$OMP PARALLEL";
1833 break;
1834 case ST_OMP_PARALLEL_DO:
1835 p = "!$OMP PARALLEL DO";
1836 break;
1837 case ST_OMP_PARALLEL_DO_SIMD:
1838 p = "!$OMP PARALLEL DO SIMD";
1839 break;
1840 case ST_OMP_PARALLEL_SECTIONS:
1841 p = "!$OMP PARALLEL SECTIONS";
1842 break;
1843 case ST_OMP_PARALLEL_WORKSHARE:
1844 p = "!$OMP PARALLEL WORKSHARE";
1845 break;
1846 case ST_OMP_SECTIONS:
1847 p = "!$OMP SECTIONS";
1848 break;
1849 case ST_OMP_SECTION:
1850 p = "!$OMP SECTION";
1851 break;
1852 case ST_OMP_SIMD:
1853 p = "!$OMP SIMD";
1854 break;
1855 case ST_OMP_SINGLE:
1856 p = "!$OMP SINGLE";
1857 break;
1858 case ST_OMP_TARGET:
1859 p = "!$OMP TARGET";
1860 break;
1861 case ST_OMP_TARGET_DATA:
1862 p = "!$OMP TARGET DATA";
1863 break;
1864 case ST_OMP_TARGET_TEAMS:
1865 p = "!$OMP TARGET TEAMS";
1866 break;
1867 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
1868 p = "!$OMP TARGET TEAMS DISTRIBUTE";
1869 break;
1870 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1871 p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
1872 break;
1873 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1874 p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
1875 break;
1876 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1877 p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
1878 break;
1879 case ST_OMP_TARGET_UPDATE:
1880 p = "!$OMP TARGET UPDATE";
1881 break;
1882 case ST_OMP_TASK:
1883 p = "!$OMP TASK";
1884 break;
1885 case ST_OMP_TASKGROUP:
1886 p = "!$OMP TASKGROUP";
1887 break;
1888 case ST_OMP_TASKWAIT:
1889 p = "!$OMP TASKWAIT";
1890 break;
1891 case ST_OMP_TASKYIELD:
1892 p = "!$OMP TASKYIELD";
1893 break;
1894 case ST_OMP_TEAMS:
1895 p = "!$OMP TEAMS";
1896 break;
1897 case ST_OMP_TEAMS_DISTRIBUTE:
1898 p = "!$OMP TEAMS DISTRIBUTE";
1899 break;
1900 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1901 p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
1902 break;
1903 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1904 p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
1905 break;
1906 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
1907 p = "!$OMP TEAMS DISTRIBUTE SIMD";
1908 break;
1909 case ST_OMP_THREADPRIVATE:
1910 p = "!$OMP THREADPRIVATE";
1911 break;
1912 case ST_OMP_WORKSHARE:
1913 p = "!$OMP WORKSHARE";
1914 break;
1915 default:
1916 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1917 }
1918
1919 return p;
1920 }
1921
1922
1923 /* Create a symbol for the main program and assign it to ns->proc_name. */
1924
1925 static void
1926 main_program_symbol (gfc_namespace *ns, const char *name)
1927 {
1928 gfc_symbol *main_program;
1929 symbol_attribute attr;
1930
1931 gfc_get_symbol (name, ns, &main_program);
1932 gfc_clear_attr (&attr);
1933 attr.flavor = FL_PROGRAM;
1934 attr.proc = PROC_UNKNOWN;
1935 attr.subroutine = 1;
1936 attr.access = ACCESS_PUBLIC;
1937 attr.is_main_program = 1;
1938 main_program->attr = attr;
1939 main_program->declared_at = gfc_current_locus;
1940 ns->proc_name = main_program;
1941 gfc_commit_symbols ();
1942 }
1943
1944
1945 /* Do whatever is necessary to accept the last statement. */
1946
1947 static void
1948 accept_statement (gfc_statement st)
1949 {
1950 switch (st)
1951 {
1952 case ST_IMPLICIT_NONE:
1953 case ST_IMPLICIT:
1954 break;
1955
1956 case ST_FUNCTION:
1957 case ST_SUBROUTINE:
1958 case ST_MODULE:
1959 gfc_current_ns->proc_name = gfc_new_block;
1960 break;
1961
1962 /* If the statement is the end of a block, lay down a special code
1963 that allows a branch to the end of the block from within the
1964 construct. IF and SELECT are treated differently from DO
1965 (where EXEC_NOP is added inside the loop) for two
1966 reasons:
1967 1. END DO has a meaning in the sense that after a GOTO to
1968 it, the loop counter must be increased.
1969 2. IF blocks and SELECT blocks can consist of multiple
1970 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1971 Putting the label before the END IF would make the jump
1972 from, say, the ELSE IF block to the END IF illegal. */
1973
1974 case ST_ENDIF:
1975 case ST_END_SELECT:
1976 case ST_END_CRITICAL:
1977 if (gfc_statement_label != NULL)
1978 {
1979 new_st.op = EXEC_END_NESTED_BLOCK;
1980 add_statement ();
1981 }
1982 break;
1983
1984 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
1985 one parallel block. Thus, we add the special code to the nested block
1986 itself, instead of the parent one. */
1987 case ST_END_BLOCK:
1988 case ST_END_ASSOCIATE:
1989 if (gfc_statement_label != NULL)
1990 {
1991 new_st.op = EXEC_END_BLOCK;
1992 add_statement ();
1993 }
1994 break;
1995
1996 /* The end-of-program unit statements do not get the special
1997 marker and require a statement of some sort if they are a
1998 branch target. */
1999
2000 case ST_END_PROGRAM:
2001 case ST_END_FUNCTION:
2002 case ST_END_SUBROUTINE:
2003 if (gfc_statement_label != NULL)
2004 {
2005 new_st.op = EXEC_RETURN;
2006 add_statement ();
2007 }
2008 else
2009 {
2010 new_st.op = EXEC_END_PROCEDURE;
2011 add_statement ();
2012 }
2013
2014 break;
2015
2016 case ST_ENTRY:
2017 case_executable:
2018 case_exec_markers:
2019 add_statement ();
2020 break;
2021
2022 default:
2023 break;
2024 }
2025
2026 gfc_commit_symbols ();
2027 gfc_warning_check ();
2028 gfc_clear_new_st ();
2029 }
2030
2031
2032 /* Undo anything tentative that has been built for the current
2033 statement. */
2034
2035 static void
2036 reject_statement (void)
2037 {
2038 /* Revert to the previous charlen chain. */
2039 gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
2040 gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
2041
2042 gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
2043 gfc_current_ns->equiv = gfc_current_ns->old_equiv;
2044
2045 gfc_new_block = NULL;
2046 gfc_undo_symbols ();
2047 gfc_clear_warning ();
2048 undo_new_statement ();
2049 }
2050
2051
2052 /* Generic complaint about an out of order statement. We also do
2053 whatever is necessary to clean up. */
2054
2055 static void
2056 unexpected_statement (gfc_statement st)
2057 {
2058 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
2059
2060 reject_statement ();
2061 }
2062
2063
2064 /* Given the next statement seen by the matcher, make sure that it is
2065 in proper order with the last. This subroutine is initialized by
2066 calling it with an argument of ST_NONE. If there is a problem, we
2067 issue an error and return false. Otherwise we return true.
2068
2069 Individual parsers need to verify that the statements seen are
2070 valid before calling here, i.e., ENTRY statements are not allowed in
2071 INTERFACE blocks. The following diagram is taken from the standard:
2072
2073 +---------------------------------------+
2074 | program subroutine function module |
2075 +---------------------------------------+
2076 | use |
2077 +---------------------------------------+
2078 | import |
2079 +---------------------------------------+
2080 | | implicit none |
2081 | +-----------+------------------+
2082 | | parameter | implicit |
2083 | +-----------+------------------+
2084 | format | | derived type |
2085 | entry | parameter | interface |
2086 | | data | specification |
2087 | | | statement func |
2088 | +-----------+------------------+
2089 | | data | executable |
2090 +--------+-----------+------------------+
2091 | contains |
2092 +---------------------------------------+
2093 | internal module/subprogram |
2094 +---------------------------------------+
2095 | end |
2096 +---------------------------------------+
2097
2098 */
2099
2100 enum state_order
2101 {
2102 ORDER_START,
2103 ORDER_USE,
2104 ORDER_IMPORT,
2105 ORDER_IMPLICIT_NONE,
2106 ORDER_IMPLICIT,
2107 ORDER_SPEC,
2108 ORDER_EXEC
2109 };
2110
2111 typedef struct
2112 {
2113 enum state_order state;
2114 gfc_statement last_statement;
2115 locus where;
2116 }
2117 st_state;
2118
2119 static bool
2120 verify_st_order (st_state *p, gfc_statement st, bool silent)
2121 {
2122
2123 switch (st)
2124 {
2125 case ST_NONE:
2126 p->state = ORDER_START;
2127 break;
2128
2129 case ST_USE:
2130 if (p->state > ORDER_USE)
2131 goto order;
2132 p->state = ORDER_USE;
2133 break;
2134
2135 case ST_IMPORT:
2136 if (p->state > ORDER_IMPORT)
2137 goto order;
2138 p->state = ORDER_IMPORT;
2139 break;
2140
2141 case ST_IMPLICIT_NONE:
2142 if (p->state > ORDER_IMPLICIT)
2143 goto order;
2144
2145 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2146 statement disqualifies a USE but not an IMPLICIT NONE.
2147 Duplicate IMPLICIT NONEs are caught when the implicit types
2148 are set. */
2149
2150 p->state = ORDER_IMPLICIT_NONE;
2151 break;
2152
2153 case ST_IMPLICIT:
2154 if (p->state > ORDER_IMPLICIT)
2155 goto order;
2156 p->state = ORDER_IMPLICIT;
2157 break;
2158
2159 case ST_FORMAT:
2160 case ST_ENTRY:
2161 if (p->state < ORDER_IMPLICIT_NONE)
2162 p->state = ORDER_IMPLICIT_NONE;
2163 break;
2164
2165 case ST_PARAMETER:
2166 if (p->state >= ORDER_EXEC)
2167 goto order;
2168 if (p->state < ORDER_IMPLICIT)
2169 p->state = ORDER_IMPLICIT;
2170 break;
2171
2172 case ST_DATA:
2173 if (p->state < ORDER_SPEC)
2174 p->state = ORDER_SPEC;
2175 break;
2176
2177 case ST_PUBLIC:
2178 case ST_PRIVATE:
2179 case ST_DERIVED_DECL:
2180 case_decl:
2181 if (p->state >= ORDER_EXEC)
2182 goto order;
2183 if (p->state < ORDER_SPEC)
2184 p->state = ORDER_SPEC;
2185 break;
2186
2187 case_executable:
2188 case_exec_markers:
2189 if (p->state < ORDER_EXEC)
2190 p->state = ORDER_EXEC;
2191 break;
2192
2193 default:
2194 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
2195 gfc_ascii_statement (st));
2196 }
2197
2198 /* All is well, record the statement in case we need it next time. */
2199 p->where = gfc_current_locus;
2200 p->last_statement = st;
2201 return true;
2202
2203 order:
2204 if (!silent)
2205 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2206 gfc_ascii_statement (st),
2207 gfc_ascii_statement (p->last_statement), &p->where);
2208
2209 return false;
2210 }
2211
2212
2213 /* Handle an unexpected end of file. This is a show-stopper... */
2214
2215 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
2216
2217 static void
2218 unexpected_eof (void)
2219 {
2220 gfc_state_data *p;
2221
2222 gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
2223
2224 /* Memory cleanup. Move to "second to last". */
2225 for (p = gfc_state_stack; p && p->previous && p->previous->previous;
2226 p = p->previous);
2227
2228 gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
2229 gfc_done_2 ();
2230
2231 longjmp (eof_buf, 1);
2232 }
2233
2234
2235 /* Parse the CONTAINS section of a derived type definition. */
2236
2237 gfc_access gfc_typebound_default_access;
2238
2239 static bool
2240 parse_derived_contains (void)
2241 {
2242 gfc_state_data s;
2243 bool seen_private = false;
2244 bool seen_comps = false;
2245 bool error_flag = false;
2246 bool to_finish;
2247
2248 gcc_assert (gfc_current_state () == COMP_DERIVED);
2249 gcc_assert (gfc_current_block ());
2250
2251 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2252 section. */
2253 if (gfc_current_block ()->attr.sequence)
2254 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
2255 " section at %C", gfc_current_block ()->name);
2256 if (gfc_current_block ()->attr.is_bind_c)
2257 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
2258 " section at %C", gfc_current_block ()->name);
2259
2260 accept_statement (ST_CONTAINS);
2261 push_state (&s, COMP_DERIVED_CONTAINS, NULL);
2262
2263 gfc_typebound_default_access = ACCESS_PUBLIC;
2264
2265 to_finish = false;
2266 while (!to_finish)
2267 {
2268 gfc_statement st;
2269 st = next_statement ();
2270 switch (st)
2271 {
2272 case ST_NONE:
2273 unexpected_eof ();
2274 break;
2275
2276 case ST_DATA_DECL:
2277 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2278 goto error;
2279
2280 case ST_PROCEDURE:
2281 if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
2282 goto error;
2283
2284 accept_statement (ST_PROCEDURE);
2285 seen_comps = true;
2286 break;
2287
2288 case ST_GENERIC:
2289 if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
2290 goto error;
2291
2292 accept_statement (ST_GENERIC);
2293 seen_comps = true;
2294 break;
2295
2296 case ST_FINAL:
2297 if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
2298 " at %C"))
2299 goto error;
2300
2301 accept_statement (ST_FINAL);
2302 seen_comps = true;
2303 break;
2304
2305 case ST_END_TYPE:
2306 to_finish = true;
2307
2308 if (!seen_comps
2309 && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
2310 "at %C with empty CONTAINS section")))
2311 goto error;
2312
2313 /* ST_END_TYPE is accepted by parse_derived after return. */
2314 break;
2315
2316 case ST_PRIVATE:
2317 if (!gfc_find_state (COMP_MODULE))
2318 {
2319 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2320 "a MODULE");
2321 goto error;
2322 }
2323
2324 if (seen_comps)
2325 {
2326 gfc_error ("PRIVATE statement at %C must precede procedure"
2327 " bindings");
2328 goto error;
2329 }
2330
2331 if (seen_private)
2332 {
2333 gfc_error ("Duplicate PRIVATE statement at %C");
2334 goto error;
2335 }
2336
2337 accept_statement (ST_PRIVATE);
2338 gfc_typebound_default_access = ACCESS_PRIVATE;
2339 seen_private = true;
2340 break;
2341
2342 case ST_SEQUENCE:
2343 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2344 goto error;
2345
2346 case ST_CONTAINS:
2347 gfc_error ("Already inside a CONTAINS block at %C");
2348 goto error;
2349
2350 default:
2351 unexpected_statement (st);
2352 break;
2353 }
2354
2355 continue;
2356
2357 error:
2358 error_flag = true;
2359 reject_statement ();
2360 }
2361
2362 pop_state ();
2363 gcc_assert (gfc_current_state () == COMP_DERIVED);
2364
2365 return error_flag;
2366 }
2367
2368
2369 /* Parse a derived type. */
2370
2371 static void
2372 parse_derived (void)
2373 {
2374 int compiling_type, seen_private, seen_sequence, seen_component;
2375 gfc_statement st;
2376 gfc_state_data s;
2377 gfc_symbol *sym;
2378 gfc_component *c, *lock_comp = NULL;
2379
2380 accept_statement (ST_DERIVED_DECL);
2381 push_state (&s, COMP_DERIVED, gfc_new_block);
2382
2383 gfc_new_block->component_access = ACCESS_PUBLIC;
2384 seen_private = 0;
2385 seen_sequence = 0;
2386 seen_component = 0;
2387
2388 compiling_type = 1;
2389
2390 while (compiling_type)
2391 {
2392 st = next_statement ();
2393 switch (st)
2394 {
2395 case ST_NONE:
2396 unexpected_eof ();
2397
2398 case ST_DATA_DECL:
2399 case ST_PROCEDURE:
2400 accept_statement (st);
2401 seen_component = 1;
2402 break;
2403
2404 case ST_FINAL:
2405 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2406 break;
2407
2408 case ST_END_TYPE:
2409 endType:
2410 compiling_type = 0;
2411
2412 if (!seen_component)
2413 gfc_notify_std (GFC_STD_F2003, "Derived type "
2414 "definition at %C without components");
2415
2416 accept_statement (ST_END_TYPE);
2417 break;
2418
2419 case ST_PRIVATE:
2420 if (!gfc_find_state (COMP_MODULE))
2421 {
2422 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2423 "a MODULE");
2424 break;
2425 }
2426
2427 if (seen_component)
2428 {
2429 gfc_error ("PRIVATE statement at %C must precede "
2430 "structure components");
2431 break;
2432 }
2433
2434 if (seen_private)
2435 gfc_error ("Duplicate PRIVATE statement at %C");
2436
2437 s.sym->component_access = ACCESS_PRIVATE;
2438
2439 accept_statement (ST_PRIVATE);
2440 seen_private = 1;
2441 break;
2442
2443 case ST_SEQUENCE:
2444 if (seen_component)
2445 {
2446 gfc_error ("SEQUENCE statement at %C must precede "
2447 "structure components");
2448 break;
2449 }
2450
2451 if (gfc_current_block ()->attr.sequence)
2452 gfc_warning ("SEQUENCE attribute at %C already specified in "
2453 "TYPE statement");
2454
2455 if (seen_sequence)
2456 {
2457 gfc_error ("Duplicate SEQUENCE statement at %C");
2458 }
2459
2460 seen_sequence = 1;
2461 gfc_add_sequence (&gfc_current_block ()->attr,
2462 gfc_current_block ()->name, NULL);
2463 break;
2464
2465 case ST_CONTAINS:
2466 gfc_notify_std (GFC_STD_F2003,
2467 "CONTAINS block in derived type"
2468 " definition at %C");
2469
2470 accept_statement (ST_CONTAINS);
2471 parse_derived_contains ();
2472 goto endType;
2473
2474 default:
2475 unexpected_statement (st);
2476 break;
2477 }
2478 }
2479
2480 /* need to verify that all fields of the derived type are
2481 * interoperable with C if the type is declared to be bind(c)
2482 */
2483 sym = gfc_current_block ();
2484 for (c = sym->components; c; c = c->next)
2485 {
2486 bool coarray, lock_type, allocatable, pointer;
2487 coarray = lock_type = allocatable = pointer = false;
2488
2489 /* Look for allocatable components. */
2490 if (c->attr.allocatable
2491 || (c->ts.type == BT_CLASS && c->attr.class_ok
2492 && CLASS_DATA (c)->attr.allocatable)
2493 || (c->ts.type == BT_DERIVED && !c->attr.pointer
2494 && c->ts.u.derived->attr.alloc_comp))
2495 {
2496 allocatable = true;
2497 sym->attr.alloc_comp = 1;
2498 }
2499
2500 /* Look for pointer components. */
2501 if (c->attr.pointer
2502 || (c->ts.type == BT_CLASS && c->attr.class_ok
2503 && CLASS_DATA (c)->attr.class_pointer)
2504 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2505 {
2506 pointer = true;
2507 sym->attr.pointer_comp = 1;
2508 }
2509
2510 /* Look for procedure pointer components. */
2511 if (c->attr.proc_pointer
2512 || (c->ts.type == BT_DERIVED
2513 && c->ts.u.derived->attr.proc_pointer_comp))
2514 sym->attr.proc_pointer_comp = 1;
2515
2516 /* Looking for coarray components. */
2517 if (c->attr.codimension
2518 || (c->ts.type == BT_CLASS && c->attr.class_ok
2519 && CLASS_DATA (c)->attr.codimension))
2520 {
2521 coarray = true;
2522 sym->attr.coarray_comp = 1;
2523 }
2524
2525 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
2526 && !c->attr.pointer)
2527 {
2528 coarray = true;
2529 sym->attr.coarray_comp = 1;
2530 }
2531
2532 /* Looking for lock_type components. */
2533 if ((c->ts.type == BT_DERIVED
2534 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2535 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2536 || (c->ts.type == BT_CLASS && c->attr.class_ok
2537 && CLASS_DATA (c)->ts.u.derived->from_intmod
2538 == INTMOD_ISO_FORTRAN_ENV
2539 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
2540 == ISOFORTRAN_LOCK_TYPE)
2541 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
2542 && !allocatable && !pointer))
2543 {
2544 lock_type = 1;
2545 lock_comp = c;
2546 sym->attr.lock_comp = 1;
2547 }
2548
2549 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2550 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2551 unless there are nondirect [allocatable or pointer] components
2552 involved (cf. 1.3.33.1 and 1.3.33.3). */
2553
2554 if (pointer && !coarray && lock_type)
2555 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2556 "codimension or be a subcomponent of a coarray, "
2557 "which is not possible as the component has the "
2558 "pointer attribute", c->name, &c->loc);
2559 else if (pointer && !coarray && c->ts.type == BT_DERIVED
2560 && c->ts.u.derived->attr.lock_comp)
2561 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2562 "of type LOCK_TYPE, which must have a codimension or be a "
2563 "subcomponent of a coarray", c->name, &c->loc);
2564
2565 if (lock_type && allocatable && !coarray)
2566 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2567 "a codimension", c->name, &c->loc);
2568 else if (lock_type && allocatable && c->ts.type == BT_DERIVED
2569 && c->ts.u.derived->attr.lock_comp)
2570 gfc_error ("Allocatable component %s at %L must have a codimension as "
2571 "it has a noncoarray subcomponent of type LOCK_TYPE",
2572 c->name, &c->loc);
2573
2574 if (sym->attr.coarray_comp && !coarray && lock_type)
2575 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2576 "subcomponent of type LOCK_TYPE must have a codimension or "
2577 "be a subcomponent of a coarray. (Variables of type %s may "
2578 "not have a codimension as already a coarray "
2579 "subcomponent exists)", c->name, &c->loc, sym->name);
2580
2581 if (sym->attr.lock_comp && coarray && !lock_type)
2582 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2583 "subcomponent of type LOCK_TYPE must have a codimension or "
2584 "be a subcomponent of a coarray. (Variables of type %s may "
2585 "not have a codimension as %s at %L has a codimension or a "
2586 "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
2587 sym->name, c->name, &c->loc);
2588
2589 /* Look for private components. */
2590 if (sym->component_access == ACCESS_PRIVATE
2591 || c->attr.access == ACCESS_PRIVATE
2592 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2593 sym->attr.private_comp = 1;
2594 }
2595
2596 if (!seen_component)
2597 sym->attr.zero_comp = 1;
2598
2599 pop_state ();
2600 }
2601
2602
2603 /* Parse an ENUM. */
2604
2605 static void
2606 parse_enum (void)
2607 {
2608 gfc_statement st;
2609 int compiling_enum;
2610 gfc_state_data s;
2611 int seen_enumerator = 0;
2612
2613 push_state (&s, COMP_ENUM, gfc_new_block);
2614
2615 compiling_enum = 1;
2616
2617 while (compiling_enum)
2618 {
2619 st = next_statement ();
2620 switch (st)
2621 {
2622 case ST_NONE:
2623 unexpected_eof ();
2624 break;
2625
2626 case ST_ENUMERATOR:
2627 seen_enumerator = 1;
2628 accept_statement (st);
2629 break;
2630
2631 case ST_END_ENUM:
2632 compiling_enum = 0;
2633 if (!seen_enumerator)
2634 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2635 accept_statement (st);
2636 break;
2637
2638 default:
2639 gfc_free_enum_history ();
2640 unexpected_statement (st);
2641 break;
2642 }
2643 }
2644 pop_state ();
2645 }
2646
2647
2648 /* Parse an interface. We must be able to deal with the possibility
2649 of recursive interfaces. The parse_spec() subroutine is mutually
2650 recursive with parse_interface(). */
2651
2652 static gfc_statement parse_spec (gfc_statement);
2653
2654 static void
2655 parse_interface (void)
2656 {
2657 gfc_compile_state new_state = COMP_NONE, current_state;
2658 gfc_symbol *prog_unit, *sym;
2659 gfc_interface_info save;
2660 gfc_state_data s1, s2;
2661 gfc_statement st;
2662
2663 accept_statement (ST_INTERFACE);
2664
2665 current_interface.ns = gfc_current_ns;
2666 save = current_interface;
2667
2668 sym = (current_interface.type == INTERFACE_GENERIC
2669 || current_interface.type == INTERFACE_USER_OP)
2670 ? gfc_new_block : NULL;
2671
2672 push_state (&s1, COMP_INTERFACE, sym);
2673 current_state = COMP_NONE;
2674
2675 loop:
2676 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2677
2678 st = next_statement ();
2679 switch (st)
2680 {
2681 case ST_NONE:
2682 unexpected_eof ();
2683
2684 case ST_SUBROUTINE:
2685 case ST_FUNCTION:
2686 if (st == ST_SUBROUTINE)
2687 new_state = COMP_SUBROUTINE;
2688 else if (st == ST_FUNCTION)
2689 new_state = COMP_FUNCTION;
2690 if (gfc_new_block->attr.pointer)
2691 {
2692 gfc_new_block->attr.pointer = 0;
2693 gfc_new_block->attr.proc_pointer = 1;
2694 }
2695 if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2696 gfc_new_block->formal, NULL))
2697 {
2698 reject_statement ();
2699 gfc_free_namespace (gfc_current_ns);
2700 goto loop;
2701 }
2702 break;
2703
2704 case ST_PROCEDURE:
2705 case ST_MODULE_PROC: /* The module procedure matcher makes
2706 sure the context is correct. */
2707 accept_statement (st);
2708 gfc_free_namespace (gfc_current_ns);
2709 goto loop;
2710
2711 case ST_END_INTERFACE:
2712 gfc_free_namespace (gfc_current_ns);
2713 gfc_current_ns = current_interface.ns;
2714 goto done;
2715
2716 default:
2717 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2718 gfc_ascii_statement (st));
2719 reject_statement ();
2720 gfc_free_namespace (gfc_current_ns);
2721 goto loop;
2722 }
2723
2724
2725 /* Make sure that the generic name has the right attribute. */
2726 if (current_interface.type == INTERFACE_GENERIC
2727 && current_state == COMP_NONE)
2728 {
2729 if (new_state == COMP_FUNCTION && sym)
2730 gfc_add_function (&sym->attr, sym->name, NULL);
2731 else if (new_state == COMP_SUBROUTINE && sym)
2732 gfc_add_subroutine (&sym->attr, sym->name, NULL);
2733
2734 current_state = new_state;
2735 }
2736
2737 if (current_interface.type == INTERFACE_ABSTRACT)
2738 {
2739 gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2740 if (gfc_is_intrinsic_typename (gfc_new_block->name))
2741 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2742 "cannot be the same as an intrinsic type",
2743 gfc_new_block->name);
2744 }
2745
2746 push_state (&s2, new_state, gfc_new_block);
2747 accept_statement (st);
2748 prog_unit = gfc_new_block;
2749 prog_unit->formal_ns = gfc_current_ns;
2750 if (prog_unit == prog_unit->formal_ns->proc_name
2751 && prog_unit->ns != prog_unit->formal_ns)
2752 prog_unit->refs++;
2753
2754 decl:
2755 /* Read data declaration statements. */
2756 st = parse_spec (ST_NONE);
2757
2758 /* Since the interface block does not permit an IMPLICIT statement,
2759 the default type for the function or the result must be taken
2760 from the formal namespace. */
2761 if (new_state == COMP_FUNCTION)
2762 {
2763 if (prog_unit->result == prog_unit
2764 && prog_unit->ts.type == BT_UNKNOWN)
2765 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2766 else if (prog_unit->result != prog_unit
2767 && prog_unit->result->ts.type == BT_UNKNOWN)
2768 gfc_set_default_type (prog_unit->result, 1,
2769 prog_unit->formal_ns);
2770 }
2771
2772 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2773 {
2774 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2775 gfc_ascii_statement (st));
2776 reject_statement ();
2777 goto decl;
2778 }
2779
2780 /* Add EXTERNAL attribute to function or subroutine. */
2781 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2782 gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2783
2784 current_interface = save;
2785 gfc_add_interface (prog_unit);
2786 pop_state ();
2787
2788 if (current_interface.ns
2789 && current_interface.ns->proc_name
2790 && strcmp (current_interface.ns->proc_name->name,
2791 prog_unit->name) == 0)
2792 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2793 "enclosing procedure", prog_unit->name,
2794 &current_interface.ns->proc_name->declared_at);
2795
2796 goto loop;
2797
2798 done:
2799 pop_state ();
2800 }
2801
2802
2803 /* Associate function characteristics by going back to the function
2804 declaration and rematching the prefix. */
2805
2806 static match
2807 match_deferred_characteristics (gfc_typespec * ts)
2808 {
2809 locus loc;
2810 match m = MATCH_ERROR;
2811 char name[GFC_MAX_SYMBOL_LEN + 1];
2812
2813 loc = gfc_current_locus;
2814
2815 gfc_current_locus = gfc_current_block ()->declared_at;
2816
2817 gfc_clear_error ();
2818 gfc_buffer_error (1);
2819 m = gfc_match_prefix (ts);
2820 gfc_buffer_error (0);
2821
2822 if (ts->type == BT_DERIVED)
2823 {
2824 ts->kind = 0;
2825
2826 if (!ts->u.derived)
2827 m = MATCH_ERROR;
2828 }
2829
2830 /* Only permit one go at the characteristic association. */
2831 if (ts->kind == -1)
2832 ts->kind = 0;
2833
2834 /* Set the function locus correctly. If we have not found the
2835 function name, there is an error. */
2836 if (m == MATCH_YES
2837 && gfc_match ("function% %n", name) == MATCH_YES
2838 && strcmp (name, gfc_current_block ()->name) == 0)
2839 {
2840 gfc_current_block ()->declared_at = gfc_current_locus;
2841 gfc_commit_symbols ();
2842 }
2843 else
2844 {
2845 gfc_error_check ();
2846 gfc_undo_symbols ();
2847 }
2848
2849 gfc_current_locus =loc;
2850 return m;
2851 }
2852
2853
2854 /* Check specification-expressions in the function result of the currently
2855 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2856 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2857 scope are not yet parsed so this has to be delayed up to parse_spec. */
2858
2859 static void
2860 check_function_result_typed (void)
2861 {
2862 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2863
2864 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2865 gcc_assert (ts->type != BT_UNKNOWN);
2866
2867 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2868 /* TODO: Extend when KIND type parameters are implemented. */
2869 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2870 gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2871 }
2872
2873
2874 /* Parse a set of specification statements. Returns the statement
2875 that doesn't fit. */
2876
2877 static gfc_statement
2878 parse_spec (gfc_statement st)
2879 {
2880 st_state ss;
2881 bool function_result_typed = false;
2882 bool bad_characteristic = false;
2883 gfc_typespec *ts;
2884
2885 verify_st_order (&ss, ST_NONE, false);
2886 if (st == ST_NONE)
2887 st = next_statement ();
2888
2889 /* If we are not inside a function or don't have a result specified so far,
2890 do nothing special about it. */
2891 if (gfc_current_state () != COMP_FUNCTION)
2892 function_result_typed = true;
2893 else
2894 {
2895 gfc_symbol* proc = gfc_current_ns->proc_name;
2896 gcc_assert (proc);
2897
2898 if (proc->result->ts.type == BT_UNKNOWN)
2899 function_result_typed = true;
2900 }
2901
2902 loop:
2903
2904 /* If we're inside a BLOCK construct, some statements are disallowed.
2905 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2906 or VALUE are also disallowed, but they don't have a particular ST_*
2907 key so we have to check for them individually in their matcher routine. */
2908 if (gfc_current_state () == COMP_BLOCK)
2909 switch (st)
2910 {
2911 case ST_IMPLICIT:
2912 case ST_IMPLICIT_NONE:
2913 case ST_NAMELIST:
2914 case ST_COMMON:
2915 case ST_EQUIVALENCE:
2916 case ST_STATEMENT_FUNCTION:
2917 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2918 gfc_ascii_statement (st));
2919 reject_statement ();
2920 break;
2921
2922 default:
2923 break;
2924 }
2925 else if (gfc_current_state () == COMP_BLOCK_DATA)
2926 /* Fortran 2008, C1116. */
2927 switch (st)
2928 {
2929 case ST_DATA_DECL:
2930 case ST_COMMON:
2931 case ST_DATA:
2932 case ST_TYPE:
2933 case ST_END_BLOCK_DATA:
2934 case ST_ATTR_DECL:
2935 case ST_EQUIVALENCE:
2936 case ST_PARAMETER:
2937 case ST_IMPLICIT:
2938 case ST_IMPLICIT_NONE:
2939 case ST_DERIVED_DECL:
2940 case ST_USE:
2941 break;
2942
2943 case ST_NONE:
2944 break;
2945
2946 default:
2947 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
2948 gfc_ascii_statement (st));
2949 reject_statement ();
2950 break;
2951 }
2952
2953 /* If we find a statement that can not be followed by an IMPLICIT statement
2954 (and thus we can expect to see none any further), type the function result
2955 if it has not yet been typed. Be careful not to give the END statement
2956 to verify_st_order! */
2957 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2958 {
2959 bool verify_now = false;
2960
2961 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2962 verify_now = true;
2963 else
2964 {
2965 st_state dummyss;
2966 verify_st_order (&dummyss, ST_NONE, false);
2967 verify_st_order (&dummyss, st, false);
2968
2969 if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
2970 verify_now = true;
2971 }
2972
2973 if (verify_now)
2974 {
2975 check_function_result_typed ();
2976 function_result_typed = true;
2977 }
2978 }
2979
2980 switch (st)
2981 {
2982 case ST_NONE:
2983 unexpected_eof ();
2984
2985 case ST_IMPLICIT_NONE:
2986 case ST_IMPLICIT:
2987 if (!function_result_typed)
2988 {
2989 check_function_result_typed ();
2990 function_result_typed = true;
2991 }
2992 goto declSt;
2993
2994 case ST_FORMAT:
2995 case ST_ENTRY:
2996 case ST_DATA: /* Not allowed in interfaces */
2997 if (gfc_current_state () == COMP_INTERFACE)
2998 break;
2999
3000 /* Fall through */
3001
3002 case ST_USE:
3003 case ST_IMPORT:
3004 case ST_PARAMETER:
3005 case ST_PUBLIC:
3006 case ST_PRIVATE:
3007 case ST_DERIVED_DECL:
3008 case_decl:
3009 declSt:
3010 if (!verify_st_order (&ss, st, false))
3011 {
3012 reject_statement ();
3013 st = next_statement ();
3014 goto loop;
3015 }
3016
3017 switch (st)
3018 {
3019 case ST_INTERFACE:
3020 parse_interface ();
3021 break;
3022
3023 case ST_DERIVED_DECL:
3024 parse_derived ();
3025 break;
3026
3027 case ST_PUBLIC:
3028 case ST_PRIVATE:
3029 if (gfc_current_state () != COMP_MODULE)
3030 {
3031 gfc_error ("%s statement must appear in a MODULE",
3032 gfc_ascii_statement (st));
3033 reject_statement ();
3034 break;
3035 }
3036
3037 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
3038 {
3039 gfc_error ("%s statement at %C follows another accessibility "
3040 "specification", gfc_ascii_statement (st));
3041 reject_statement ();
3042 break;
3043 }
3044
3045 gfc_current_ns->default_access = (st == ST_PUBLIC)
3046 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3047
3048 break;
3049
3050 case ST_STATEMENT_FUNCTION:
3051 if (gfc_current_state () == COMP_MODULE)
3052 {
3053 unexpected_statement (st);
3054 break;
3055 }
3056
3057 default:
3058 break;
3059 }
3060
3061 accept_statement (st);
3062 st = next_statement ();
3063 goto loop;
3064
3065 case ST_ENUM:
3066 accept_statement (st);
3067 parse_enum();
3068 st = next_statement ();
3069 goto loop;
3070
3071 case ST_GET_FCN_CHARACTERISTICS:
3072 /* This statement triggers the association of a function's result
3073 characteristics. */
3074 ts = &gfc_current_block ()->result->ts;
3075 if (match_deferred_characteristics (ts) != MATCH_YES)
3076 bad_characteristic = true;
3077
3078 st = next_statement ();
3079 goto loop;
3080
3081 default:
3082 break;
3083 }
3084
3085 /* If match_deferred_characteristics failed, then there is an error. */
3086 if (bad_characteristic)
3087 {
3088 ts = &gfc_current_block ()->result->ts;
3089 if (ts->type != BT_DERIVED)
3090 gfc_error ("Bad kind expression for function '%s' at %L",
3091 gfc_current_block ()->name,
3092 &gfc_current_block ()->declared_at);
3093 else
3094 gfc_error ("The type for function '%s' at %L is not accessible",
3095 gfc_current_block ()->name,
3096 &gfc_current_block ()->declared_at);
3097
3098 gfc_current_block ()->ts.kind = 0;
3099 /* Keep the derived type; if it's bad, it will be discovered later. */
3100 if (!(ts->type == BT_DERIVED && ts->u.derived))
3101 ts->type = BT_UNKNOWN;
3102 }
3103
3104 return st;
3105 }
3106
3107
3108 /* Parse a WHERE block, (not a simple WHERE statement). */
3109
3110 static void
3111 parse_where_block (void)
3112 {
3113 int seen_empty_else;
3114 gfc_code *top, *d;
3115 gfc_state_data s;
3116 gfc_statement st;
3117
3118 accept_statement (ST_WHERE_BLOCK);
3119 top = gfc_state_stack->tail;
3120
3121 push_state (&s, COMP_WHERE, gfc_new_block);
3122
3123 d = add_statement ();
3124 d->expr1 = top->expr1;
3125 d->op = EXEC_WHERE;
3126
3127 top->expr1 = NULL;
3128 top->block = d;
3129
3130 seen_empty_else = 0;
3131
3132 do
3133 {
3134 st = next_statement ();
3135 switch (st)
3136 {
3137 case ST_NONE:
3138 unexpected_eof ();
3139
3140 case ST_WHERE_BLOCK:
3141 parse_where_block ();
3142 break;
3143
3144 case ST_ASSIGNMENT:
3145 case ST_WHERE:
3146 accept_statement (st);
3147 break;
3148
3149 case ST_ELSEWHERE:
3150 if (seen_empty_else)
3151 {
3152 gfc_error ("ELSEWHERE statement at %C follows previous "
3153 "unmasked ELSEWHERE");
3154 reject_statement ();
3155 break;
3156 }
3157
3158 if (new_st.expr1 == NULL)
3159 seen_empty_else = 1;
3160
3161 d = new_level (gfc_state_stack->head);
3162 d->op = EXEC_WHERE;
3163 d->expr1 = new_st.expr1;
3164
3165 accept_statement (st);
3166
3167 break;
3168
3169 case ST_END_WHERE:
3170 accept_statement (st);
3171 break;
3172
3173 default:
3174 gfc_error ("Unexpected %s statement in WHERE block at %C",
3175 gfc_ascii_statement (st));
3176 reject_statement ();
3177 break;
3178 }
3179 }
3180 while (st != ST_END_WHERE);
3181
3182 pop_state ();
3183 }
3184
3185
3186 /* Parse a FORALL block (not a simple FORALL statement). */
3187
3188 static void
3189 parse_forall_block (void)
3190 {
3191 gfc_code *top, *d;
3192 gfc_state_data s;
3193 gfc_statement st;
3194
3195 accept_statement (ST_FORALL_BLOCK);
3196 top = gfc_state_stack->tail;
3197
3198 push_state (&s, COMP_FORALL, gfc_new_block);
3199
3200 d = add_statement ();
3201 d->op = EXEC_FORALL;
3202 top->block = d;
3203
3204 do
3205 {
3206 st = next_statement ();
3207 switch (st)
3208 {
3209
3210 case ST_ASSIGNMENT:
3211 case ST_POINTER_ASSIGNMENT:
3212 case ST_WHERE:
3213 case ST_FORALL:
3214 accept_statement (st);
3215 break;
3216
3217 case ST_WHERE_BLOCK:
3218 parse_where_block ();
3219 break;
3220
3221 case ST_FORALL_BLOCK:
3222 parse_forall_block ();
3223 break;
3224
3225 case ST_END_FORALL:
3226 accept_statement (st);
3227 break;
3228
3229 case ST_NONE:
3230 unexpected_eof ();
3231
3232 default:
3233 gfc_error ("Unexpected %s statement in FORALL block at %C",
3234 gfc_ascii_statement (st));
3235
3236 reject_statement ();
3237 break;
3238 }
3239 }
3240 while (st != ST_END_FORALL);
3241
3242 pop_state ();
3243 }
3244
3245
3246 static gfc_statement parse_executable (gfc_statement);
3247
3248 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3249
3250 static void
3251 parse_if_block (void)
3252 {
3253 gfc_code *top, *d;
3254 gfc_statement st;
3255 locus else_locus;
3256 gfc_state_data s;
3257 int seen_else;
3258
3259 seen_else = 0;
3260 accept_statement (ST_IF_BLOCK);
3261
3262 top = gfc_state_stack->tail;
3263 push_state (&s, COMP_IF, gfc_new_block);
3264
3265 new_st.op = EXEC_IF;
3266 d = add_statement ();
3267
3268 d->expr1 = top->expr1;
3269 top->expr1 = NULL;
3270 top->block = d;
3271
3272 do
3273 {
3274 st = parse_executable (ST_NONE);
3275
3276 switch (st)
3277 {
3278 case ST_NONE:
3279 unexpected_eof ();
3280
3281 case ST_ELSEIF:
3282 if (seen_else)
3283 {
3284 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3285 "statement at %L", &else_locus);
3286
3287 reject_statement ();
3288 break;
3289 }
3290
3291 d = new_level (gfc_state_stack->head);
3292 d->op = EXEC_IF;
3293 d->expr1 = new_st.expr1;
3294
3295 accept_statement (st);
3296
3297 break;
3298
3299 case ST_ELSE:
3300 if (seen_else)
3301 {
3302 gfc_error ("Duplicate ELSE statements at %L and %C",
3303 &else_locus);
3304 reject_statement ();
3305 break;
3306 }
3307
3308 seen_else = 1;
3309 else_locus = gfc_current_locus;
3310
3311 d = new_level (gfc_state_stack->head);
3312 d->op = EXEC_IF;
3313
3314 accept_statement (st);
3315
3316 break;
3317
3318 case ST_ENDIF:
3319 break;
3320
3321 default:
3322 unexpected_statement (st);
3323 break;
3324 }
3325 }
3326 while (st != ST_ENDIF);
3327
3328 pop_state ();
3329 accept_statement (st);
3330 }
3331
3332
3333 /* Parse a SELECT block. */
3334
3335 static void
3336 parse_select_block (void)
3337 {
3338 gfc_statement st;
3339 gfc_code *cp;
3340 gfc_state_data s;
3341
3342 accept_statement (ST_SELECT_CASE);
3343
3344 cp = gfc_state_stack->tail;
3345 push_state (&s, COMP_SELECT, gfc_new_block);
3346
3347 /* Make sure that the next statement is a CASE or END SELECT. */
3348 for (;;)
3349 {
3350 st = next_statement ();
3351 if (st == ST_NONE)
3352 unexpected_eof ();
3353 if (st == ST_END_SELECT)
3354 {
3355 /* Empty SELECT CASE is OK. */
3356 accept_statement (st);
3357 pop_state ();
3358 return;
3359 }
3360 if (st == ST_CASE)
3361 break;
3362
3363 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3364 "CASE at %C");
3365
3366 reject_statement ();
3367 }
3368
3369 /* At this point, we're got a nonempty select block. */
3370 cp = new_level (cp);
3371 *cp = new_st;
3372
3373 accept_statement (st);
3374
3375 do
3376 {
3377 st = parse_executable (ST_NONE);
3378 switch (st)
3379 {
3380 case ST_NONE:
3381 unexpected_eof ();
3382
3383 case ST_CASE:
3384 cp = new_level (gfc_state_stack->head);
3385 *cp = new_st;
3386 gfc_clear_new_st ();
3387
3388 accept_statement (st);
3389 /* Fall through */
3390
3391 case ST_END_SELECT:
3392 break;
3393
3394 /* Can't have an executable statement because of
3395 parse_executable(). */
3396 default:
3397 unexpected_statement (st);
3398 break;
3399 }
3400 }
3401 while (st != ST_END_SELECT);
3402
3403 pop_state ();
3404 accept_statement (st);
3405 }
3406
3407
3408 /* Pop the current selector from the SELECT TYPE stack. */
3409
3410 static void
3411 select_type_pop (void)
3412 {
3413 gfc_select_type_stack *old = select_type_stack;
3414 select_type_stack = old->prev;
3415 free (old);
3416 }
3417
3418
3419 /* Parse a SELECT TYPE construct (F03:R821). */
3420
3421 static void
3422 parse_select_type_block (void)
3423 {
3424 gfc_statement st;
3425 gfc_code *cp;
3426 gfc_state_data s;
3427
3428 accept_statement (ST_SELECT_TYPE);
3429
3430 cp = gfc_state_stack->tail;
3431 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
3432
3433 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3434 or END SELECT. */
3435 for (;;)
3436 {
3437 st = next_statement ();
3438 if (st == ST_NONE)
3439 unexpected_eof ();
3440 if (st == ST_END_SELECT)
3441 /* Empty SELECT CASE is OK. */
3442 goto done;
3443 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
3444 break;
3445
3446 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3447 "following SELECT TYPE at %C");
3448
3449 reject_statement ();
3450 }
3451
3452 /* At this point, we're got a nonempty select block. */
3453 cp = new_level (cp);
3454 *cp = new_st;
3455
3456 accept_statement (st);
3457
3458 do
3459 {
3460 st = parse_executable (ST_NONE);
3461 switch (st)
3462 {
3463 case ST_NONE:
3464 unexpected_eof ();
3465
3466 case ST_TYPE_IS:
3467 case ST_CLASS_IS:
3468 cp = new_level (gfc_state_stack->head);
3469 *cp = new_st;
3470 gfc_clear_new_st ();
3471
3472 accept_statement (st);
3473 /* Fall through */
3474
3475 case ST_END_SELECT:
3476 break;
3477
3478 /* Can't have an executable statement because of
3479 parse_executable(). */
3480 default:
3481 unexpected_statement (st);
3482 break;
3483 }
3484 }
3485 while (st != ST_END_SELECT);
3486
3487 done:
3488 pop_state ();
3489 accept_statement (st);
3490 gfc_current_ns = gfc_current_ns->parent;
3491 select_type_pop ();
3492 }
3493
3494
3495 /* Given a symbol, make sure it is not an iteration variable for a DO
3496 statement. This subroutine is called when the symbol is seen in a
3497 context that causes it to become redefined. If the symbol is an
3498 iterator, we generate an error message and return nonzero. */
3499
3500 int
3501 gfc_check_do_variable (gfc_symtree *st)
3502 {
3503 gfc_state_data *s;
3504
3505 for (s=gfc_state_stack; s; s = s->previous)
3506 if (s->do_variable == st)
3507 {
3508 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3509 "loop beginning at %L", st->name, &s->head->loc);
3510 return 1;
3511 }
3512
3513 return 0;
3514 }
3515
3516
3517 /* Checks to see if the current statement label closes an enddo.
3518 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3519 an error) if it incorrectly closes an ENDDO. */
3520
3521 static int
3522 check_do_closure (void)
3523 {
3524 gfc_state_data *p;
3525
3526 if (gfc_statement_label == NULL)
3527 return 0;
3528
3529 for (p = gfc_state_stack; p; p = p->previous)
3530 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3531 break;
3532
3533 if (p == NULL)
3534 return 0; /* No loops to close */
3535
3536 if (p->ext.end_do_label == gfc_statement_label)
3537 {
3538 if (p == gfc_state_stack)
3539 return 1;
3540
3541 gfc_error ("End of nonblock DO statement at %C is within another block");
3542 return 2;
3543 }
3544
3545 /* At this point, the label doesn't terminate the innermost loop.
3546 Make sure it doesn't terminate another one. */
3547 for (; p; p = p->previous)
3548 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3549 && p->ext.end_do_label == gfc_statement_label)
3550 {
3551 gfc_error ("End of nonblock DO statement at %C is interwoven "
3552 "with another DO loop");
3553 return 2;
3554 }
3555
3556 return 0;
3557 }
3558
3559
3560 /* Parse a series of contained program units. */
3561
3562 static void parse_progunit (gfc_statement);
3563
3564
3565 /* Parse a CRITICAL block. */
3566
3567 static void
3568 parse_critical_block (void)
3569 {
3570 gfc_code *top, *d;
3571 gfc_state_data s;
3572 gfc_statement st;
3573
3574 s.ext.end_do_label = new_st.label1;
3575
3576 accept_statement (ST_CRITICAL);
3577 top = gfc_state_stack->tail;
3578
3579 push_state (&s, COMP_CRITICAL, gfc_new_block);
3580
3581 d = add_statement ();
3582 d->op = EXEC_CRITICAL;
3583 top->block = d;
3584
3585 do
3586 {
3587 st = parse_executable (ST_NONE);
3588
3589 switch (st)
3590 {
3591 case ST_NONE:
3592 unexpected_eof ();
3593 break;
3594
3595 case ST_END_CRITICAL:
3596 if (s.ext.end_do_label != NULL
3597 && s.ext.end_do_label != gfc_statement_label)
3598 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3599 "match CRITICAL label");
3600
3601 if (gfc_statement_label != NULL)
3602 {
3603 new_st.op = EXEC_NOP;
3604 add_statement ();
3605 }
3606 break;
3607
3608 default:
3609 unexpected_statement (st);
3610 break;
3611 }
3612 }
3613 while (st != ST_END_CRITICAL);
3614
3615 pop_state ();
3616 accept_statement (st);
3617 }
3618
3619
3620 /* Set up the local namespace for a BLOCK construct. */
3621
3622 gfc_namespace*
3623 gfc_build_block_ns (gfc_namespace *parent_ns)
3624 {
3625 gfc_namespace* my_ns;
3626 static int numblock = 1;
3627
3628 my_ns = gfc_get_namespace (parent_ns, 1);
3629 my_ns->construct_entities = 1;
3630
3631 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3632 code generation (so it must not be NULL).
3633 We set its recursive argument if our container procedure is recursive, so
3634 that local variables are accordingly placed on the stack when it
3635 will be necessary. */
3636 if (gfc_new_block)
3637 my_ns->proc_name = gfc_new_block;
3638 else
3639 {
3640 bool t;
3641 char buffer[20]; /* Enough to hold "block@2147483648\n". */
3642
3643 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
3644 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
3645 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3646 my_ns->proc_name->name, NULL);
3647 gcc_assert (t);
3648 gfc_commit_symbol (my_ns->proc_name);
3649 }
3650
3651 if (parent_ns->proc_name)
3652 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3653
3654 return my_ns;
3655 }
3656
3657
3658 /* Parse a BLOCK construct. */
3659
3660 static void
3661 parse_block_construct (void)
3662 {
3663 gfc_namespace* my_ns;
3664 gfc_state_data s;
3665
3666 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
3667
3668 my_ns = gfc_build_block_ns (gfc_current_ns);
3669
3670 new_st.op = EXEC_BLOCK;
3671 new_st.ext.block.ns = my_ns;
3672 new_st.ext.block.assoc = NULL;
3673 accept_statement (ST_BLOCK);
3674
3675 push_state (&s, COMP_BLOCK, my_ns->proc_name);
3676 gfc_current_ns = my_ns;
3677
3678 parse_progunit (ST_NONE);
3679
3680 gfc_current_ns = gfc_current_ns->parent;
3681 pop_state ();
3682 }
3683
3684
3685 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3686 behind the scenes with compiler-generated variables. */
3687
3688 static void
3689 parse_associate (void)
3690 {
3691 gfc_namespace* my_ns;
3692 gfc_state_data s;
3693 gfc_statement st;
3694 gfc_association_list* a;
3695
3696 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
3697
3698 my_ns = gfc_build_block_ns (gfc_current_ns);
3699
3700 new_st.op = EXEC_BLOCK;
3701 new_st.ext.block.ns = my_ns;
3702 gcc_assert (new_st.ext.block.assoc);
3703
3704 /* Add all associate-names as BLOCK variables. Creating them is enough
3705 for now, they'll get their values during trans-* phase. */
3706 gfc_current_ns = my_ns;
3707 for (a = new_st.ext.block.assoc; a; a = a->next)
3708 {
3709 gfc_symbol* sym;
3710
3711 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3712 gcc_unreachable ();
3713
3714 sym = a->st->n.sym;
3715 sym->attr.flavor = FL_VARIABLE;
3716 sym->assoc = a;
3717 sym->declared_at = a->where;
3718 gfc_set_sym_referenced (sym);
3719
3720 /* Initialize the typespec. It is not available in all cases,
3721 however, as it may only be set on the target during resolution.
3722 Still, sometimes it helps to have it right now -- especially
3723 for parsing component references on the associate-name
3724 in case of association to a derived-type. */
3725 sym->ts = a->target->ts;
3726 }
3727
3728 accept_statement (ST_ASSOCIATE);
3729 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3730
3731 loop:
3732 st = parse_executable (ST_NONE);
3733 switch (st)
3734 {
3735 case ST_NONE:
3736 unexpected_eof ();
3737
3738 case_end:
3739 accept_statement (st);
3740 my_ns->code = gfc_state_stack->head;
3741 break;
3742
3743 default:
3744 unexpected_statement (st);
3745 goto loop;
3746 }
3747
3748 gfc_current_ns = gfc_current_ns->parent;
3749 pop_state ();
3750 }
3751
3752
3753 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3754 handled inside of parse_executable(), because they aren't really
3755 loop statements. */
3756
3757 static void
3758 parse_do_block (void)
3759 {
3760 gfc_statement st;
3761 gfc_code *top;
3762 gfc_state_data s;
3763 gfc_symtree *stree;
3764 gfc_exec_op do_op;
3765
3766 do_op = new_st.op;
3767 s.ext.end_do_label = new_st.label1;
3768
3769 if (new_st.ext.iterator != NULL)
3770 stree = new_st.ext.iterator->var->symtree;
3771 else
3772 stree = NULL;
3773
3774 accept_statement (ST_DO);
3775
3776 top = gfc_state_stack->tail;
3777 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
3778 gfc_new_block);
3779
3780 s.do_variable = stree;
3781
3782 top->block = new_level (top);
3783 top->block->op = EXEC_DO;
3784
3785 loop:
3786 st = parse_executable (ST_NONE);
3787
3788 switch (st)
3789 {
3790 case ST_NONE:
3791 unexpected_eof ();
3792
3793 case ST_ENDDO:
3794 if (s.ext.end_do_label != NULL
3795 && s.ext.end_do_label != gfc_statement_label)
3796 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3797 "DO label");
3798
3799 if (gfc_statement_label != NULL)
3800 {
3801 new_st.op = EXEC_NOP;
3802 add_statement ();
3803 }
3804 break;
3805
3806 case ST_IMPLIED_ENDDO:
3807 /* If the do-stmt of this DO construct has a do-construct-name,
3808 the corresponding end-do must be an end-do-stmt (with a matching
3809 name, but in that case we must have seen ST_ENDDO first).
3810 We only complain about this in pedantic mode. */
3811 if (gfc_current_block () != NULL)
3812 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3813 &gfc_current_block()->declared_at);
3814
3815 break;
3816
3817 default:
3818 unexpected_statement (st);
3819 goto loop;
3820 }
3821
3822 pop_state ();
3823 accept_statement (st);
3824 }
3825
3826
3827 /* Parse the statements of OpenMP do/parallel do. */
3828
3829 static gfc_statement
3830 parse_omp_do (gfc_statement omp_st)
3831 {
3832 gfc_statement st;
3833 gfc_code *cp, *np;
3834 gfc_state_data s;
3835
3836 accept_statement (omp_st);
3837
3838 cp = gfc_state_stack->tail;
3839 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3840 np = new_level (cp);
3841 np->op = cp->op;
3842 np->block = NULL;
3843
3844 for (;;)
3845 {
3846 st = next_statement ();
3847 if (st == ST_NONE)
3848 unexpected_eof ();
3849 else if (st == ST_DO)
3850 break;
3851 else
3852 unexpected_statement (st);
3853 }
3854
3855 parse_do_block ();
3856 if (gfc_statement_label != NULL
3857 && gfc_state_stack->previous != NULL
3858 && gfc_state_stack->previous->state == COMP_DO
3859 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3860 {
3861 /* In
3862 DO 100 I=1,10
3863 !$OMP DO
3864 DO J=1,10
3865 ...
3866 100 CONTINUE
3867 there should be no !$OMP END DO. */
3868 pop_state ();
3869 return ST_IMPLIED_ENDDO;
3870 }
3871
3872 check_do_closure ();
3873 pop_state ();
3874
3875 st = next_statement ();
3876 gfc_statement omp_end_st = ST_OMP_END_DO;
3877 switch (omp_st)
3878 {
3879 case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
3880 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
3881 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
3882 break;
3883 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3884 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
3885 break;
3886 case ST_OMP_DISTRIBUTE_SIMD:
3887 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
3888 break;
3889 case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
3890 case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
3891 case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
3892 case ST_OMP_PARALLEL_DO_SIMD:
3893 omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
3894 break;
3895 case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
3896 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
3897 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
3898 break;
3899 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3900 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
3901 break;
3902 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3903 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
3904 break;
3905 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3906 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
3907 break;
3908 case ST_OMP_TEAMS_DISTRIBUTE:
3909 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
3910 break;
3911 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3912 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
3913 break;
3914 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3915 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
3916 break;
3917 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
3918 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
3919 break;
3920 default: gcc_unreachable ();
3921 }
3922 if (st == omp_end_st)
3923 {
3924 if (new_st.op == EXEC_OMP_END_NOWAIT)
3925 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3926 else
3927 gcc_assert (new_st.op == EXEC_NOP);
3928 gfc_clear_new_st ();
3929 gfc_commit_symbols ();
3930 gfc_warning_check ();
3931 st = next_statement ();
3932 }
3933 return st;
3934 }
3935
3936
3937 /* Parse the statements of OpenMP atomic directive. */
3938
3939 static gfc_statement
3940 parse_omp_atomic (void)
3941 {
3942 gfc_statement st;
3943 gfc_code *cp, *np;
3944 gfc_state_data s;
3945 int count;
3946
3947 accept_statement (ST_OMP_ATOMIC);
3948
3949 cp = gfc_state_stack->tail;
3950 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3951 np = new_level (cp);
3952 np->op = cp->op;
3953 np->block = NULL;
3954 count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3955 == GFC_OMP_ATOMIC_CAPTURE);
3956
3957 while (count)
3958 {
3959 st = next_statement ();
3960 if (st == ST_NONE)
3961 unexpected_eof ();
3962 else if (st == ST_ASSIGNMENT)
3963 {
3964 accept_statement (st);
3965 count--;
3966 }
3967 else
3968 unexpected_statement (st);
3969 }
3970
3971 pop_state ();
3972
3973 st = next_statement ();
3974 if (st == ST_OMP_END_ATOMIC)
3975 {
3976 gfc_clear_new_st ();
3977 gfc_commit_symbols ();
3978 gfc_warning_check ();
3979 st = next_statement ();
3980 }
3981 else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3982 == GFC_OMP_ATOMIC_CAPTURE)
3983 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3984 return st;
3985 }
3986
3987
3988 /* Parse the statements of an OpenMP structured block. */
3989
3990 static void
3991 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3992 {
3993 gfc_statement st, omp_end_st;
3994 gfc_code *cp, *np;
3995 gfc_state_data s;
3996
3997 accept_statement (omp_st);
3998
3999 cp = gfc_state_stack->tail;
4000 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
4001 np = new_level (cp);
4002 np->op = cp->op;
4003 np->block = NULL;
4004
4005 switch (omp_st)
4006 {
4007 case ST_OMP_PARALLEL:
4008 omp_end_st = ST_OMP_END_PARALLEL;
4009 break;
4010 case ST_OMP_PARALLEL_SECTIONS:
4011 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
4012 break;
4013 case ST_OMP_SECTIONS:
4014 omp_end_st = ST_OMP_END_SECTIONS;
4015 break;
4016 case ST_OMP_ORDERED:
4017 omp_end_st = ST_OMP_END_ORDERED;
4018 break;
4019 case ST_OMP_CRITICAL:
4020 omp_end_st = ST_OMP_END_CRITICAL;
4021 break;
4022 case ST_OMP_MASTER:
4023 omp_end_st = ST_OMP_END_MASTER;
4024 break;
4025 case ST_OMP_SINGLE:
4026 omp_end_st = ST_OMP_END_SINGLE;
4027 break;
4028 case ST_OMP_TARGET:
4029 omp_end_st = ST_OMP_END_TARGET;
4030 break;
4031 case ST_OMP_TARGET_DATA:
4032 omp_end_st = ST_OMP_END_TARGET_DATA;
4033 break;
4034 case ST_OMP_TARGET_TEAMS:
4035 omp_end_st = ST_OMP_END_TARGET_TEAMS;
4036 break;
4037 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4038 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
4039 break;
4040 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4041 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
4042 break;
4043 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4044 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4045 break;
4046 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4047 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
4048 break;
4049 case ST_OMP_TASK:
4050 omp_end_st = ST_OMP_END_TASK;
4051 break;
4052 case ST_OMP_TASKGROUP:
4053 omp_end_st = ST_OMP_END_TASKGROUP;
4054 break;
4055 case ST_OMP_TEAMS:
4056 omp_end_st = ST_OMP_END_TEAMS;
4057 break;
4058 case ST_OMP_TEAMS_DISTRIBUTE:
4059 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
4060 break;
4061 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4062 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
4063 break;
4064 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4065 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4066 break;
4067 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
4068 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
4069 break;
4070 case ST_OMP_DISTRIBUTE:
4071 omp_end_st = ST_OMP_END_DISTRIBUTE;
4072 break;
4073 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4074 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
4075 break;
4076 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4077 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
4078 break;
4079 case ST_OMP_DISTRIBUTE_SIMD:
4080 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
4081 break;
4082 case ST_OMP_WORKSHARE:
4083 omp_end_st = ST_OMP_END_WORKSHARE;
4084 break;
4085 case ST_OMP_PARALLEL_WORKSHARE:
4086 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
4087 break;
4088 default:
4089 gcc_unreachable ();
4090 }
4091
4092 do
4093 {
4094 if (workshare_stmts_only)
4095 {
4096 /* Inside of !$omp workshare, only
4097 scalar assignments
4098 array assignments
4099 where statements and constructs
4100 forall statements and constructs
4101 !$omp atomic
4102 !$omp critical
4103 !$omp parallel
4104 are allowed. For !$omp critical these
4105 restrictions apply recursively. */
4106 bool cycle = true;
4107
4108 st = next_statement ();
4109 for (;;)
4110 {
4111 switch (st)
4112 {
4113 case ST_NONE:
4114 unexpected_eof ();
4115
4116 case ST_ASSIGNMENT:
4117 case ST_WHERE:
4118 case ST_FORALL:
4119 accept_statement (st);
4120 break;
4121
4122 case ST_WHERE_BLOCK:
4123 parse_where_block ();
4124 break;
4125
4126 case ST_FORALL_BLOCK:
4127 parse_forall_block ();
4128 break;
4129
4130 case ST_OMP_PARALLEL:
4131 case ST_OMP_PARALLEL_SECTIONS:
4132 parse_omp_structured_block (st, false);
4133 break;
4134
4135 case ST_OMP_PARALLEL_WORKSHARE:
4136 case ST_OMP_CRITICAL:
4137 parse_omp_structured_block (st, true);
4138 break;
4139
4140 case ST_OMP_PARALLEL_DO:
4141 case ST_OMP_PARALLEL_DO_SIMD:
4142 st = parse_omp_do (st);
4143 continue;
4144
4145 case ST_OMP_ATOMIC:
4146 st = parse_omp_atomic ();
4147 continue;
4148
4149 default:
4150 cycle = false;
4151 break;
4152 }
4153
4154 if (!cycle)
4155 break;
4156
4157 st = next_statement ();
4158 }
4159 }
4160 else
4161 st = parse_executable (ST_NONE);
4162 if (st == ST_NONE)
4163 unexpected_eof ();
4164 else if (st == ST_OMP_SECTION
4165 && (omp_st == ST_OMP_SECTIONS
4166 || omp_st == ST_OMP_PARALLEL_SECTIONS))
4167 {
4168 np = new_level (np);
4169 np->op = cp->op;
4170 np->block = NULL;
4171 }
4172 else if (st != omp_end_st)
4173 unexpected_statement (st);
4174 }
4175 while (st != omp_end_st);
4176
4177 switch (new_st.op)
4178 {
4179 case EXEC_OMP_END_NOWAIT:
4180 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
4181 break;
4182 case EXEC_OMP_CRITICAL:
4183 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
4184 || (new_st.ext.omp_name != NULL
4185 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
4186 gfc_error ("Name after !$omp critical and !$omp end critical does "
4187 "not match at %C");
4188 free (CONST_CAST (char *, new_st.ext.omp_name));
4189 break;
4190 case EXEC_OMP_END_SINGLE:
4191 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
4192 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
4193 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
4194 gfc_free_omp_clauses (new_st.ext.omp_clauses);
4195 break;
4196 case EXEC_NOP:
4197 break;
4198 default:
4199 gcc_unreachable ();
4200 }
4201
4202 gfc_clear_new_st ();
4203 gfc_commit_symbols ();
4204 gfc_warning_check ();
4205 pop_state ();
4206 }
4207
4208
4209 /* Accept a series of executable statements. We return the first
4210 statement that doesn't fit to the caller. Any block statements are
4211 passed on to the correct handler, which usually passes the buck
4212 right back here. */
4213
4214 static gfc_statement
4215 parse_executable (gfc_statement st)
4216 {
4217 int close_flag;
4218
4219 if (st == ST_NONE)
4220 st = next_statement ();
4221
4222 for (;;)
4223 {
4224 close_flag = check_do_closure ();
4225 if (close_flag)
4226 switch (st)
4227 {
4228 case ST_GOTO:
4229 case ST_END_PROGRAM:
4230 case ST_RETURN:
4231 case ST_EXIT:
4232 case ST_END_FUNCTION:
4233 case ST_CYCLE:
4234 case ST_PAUSE:
4235 case ST_STOP:
4236 case ST_ERROR_STOP:
4237 case ST_END_SUBROUTINE:
4238
4239 case ST_DO:
4240 case ST_FORALL:
4241 case ST_WHERE:
4242 case ST_SELECT_CASE:
4243 gfc_error ("%s statement at %C cannot terminate a non-block "
4244 "DO loop", gfc_ascii_statement (st));
4245 break;
4246
4247 default:
4248 break;
4249 }
4250
4251 switch (st)
4252 {
4253 case ST_NONE:
4254 unexpected_eof ();
4255
4256 case ST_DATA:
4257 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
4258 "first executable statement");
4259 /* Fall through. */
4260
4261 case ST_FORMAT:
4262 case ST_ENTRY:
4263 case_executable:
4264 accept_statement (st);
4265 if (close_flag == 1)
4266 return ST_IMPLIED_ENDDO;
4267 break;
4268
4269 case ST_BLOCK:
4270 parse_block_construct ();
4271 break;
4272
4273 case ST_ASSOCIATE:
4274 parse_associate ();
4275 break;
4276
4277 case ST_IF_BLOCK:
4278 parse_if_block ();
4279 break;
4280
4281 case ST_SELECT_CASE:
4282 parse_select_block ();
4283 break;
4284
4285 case ST_SELECT_TYPE:
4286 parse_select_type_block();
4287 break;
4288
4289 case ST_DO:
4290 parse_do_block ();
4291 if (check_do_closure () == 1)
4292 return ST_IMPLIED_ENDDO;
4293 break;
4294
4295 case ST_CRITICAL:
4296 parse_critical_block ();
4297 break;
4298
4299 case ST_WHERE_BLOCK:
4300 parse_where_block ();
4301 break;
4302
4303 case ST_FORALL_BLOCK:
4304 parse_forall_block ();
4305 break;
4306
4307 case ST_OMP_PARALLEL:
4308 case ST_OMP_PARALLEL_SECTIONS:
4309 case ST_OMP_SECTIONS:
4310 case ST_OMP_ORDERED:
4311 case ST_OMP_CRITICAL:
4312 case ST_OMP_MASTER:
4313 case ST_OMP_SINGLE:
4314 case ST_OMP_TARGET:
4315 case ST_OMP_TARGET_DATA:
4316 case ST_OMP_TARGET_TEAMS:
4317 case ST_OMP_TEAMS:
4318 case ST_OMP_TASK:
4319 case ST_OMP_TASKGROUP:
4320 parse_omp_structured_block (st, false);
4321 break;
4322
4323 case ST_OMP_WORKSHARE:
4324 case ST_OMP_PARALLEL_WORKSHARE:
4325 parse_omp_structured_block (st, true);
4326 break;
4327
4328 case ST_OMP_DISTRIBUTE:
4329 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4330 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4331 case ST_OMP_DISTRIBUTE_SIMD:
4332 case ST_OMP_DO:
4333 case ST_OMP_DO_SIMD:
4334 case ST_OMP_PARALLEL_DO:
4335 case ST_OMP_PARALLEL_DO_SIMD:
4336 case ST_OMP_SIMD:
4337 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4338 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4339 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4340 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4341 case ST_OMP_TEAMS_DISTRIBUTE:
4342 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4343 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4344 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
4345 st = parse_omp_do (st);
4346 if (st == ST_IMPLIED_ENDDO)
4347 return st;
4348 continue;
4349
4350 case ST_OMP_ATOMIC:
4351 st = parse_omp_atomic ();
4352 continue;
4353
4354 default:
4355 return st;
4356 }
4357
4358 st = next_statement ();
4359 }
4360 }
4361
4362
4363 /* Fix the symbols for sibling functions. These are incorrectly added to
4364 the child namespace as the parser didn't know about this procedure. */
4365
4366 static void
4367 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
4368 {
4369 gfc_namespace *ns;
4370 gfc_symtree *st;
4371 gfc_symbol *old_sym;
4372
4373 for (ns = siblings; ns; ns = ns->sibling)
4374 {
4375 st = gfc_find_symtree (ns->sym_root, sym->name);
4376
4377 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
4378 goto fixup_contained;
4379
4380 if ((st->n.sym->attr.flavor == FL_DERIVED
4381 && sym->attr.generic && sym->attr.function)
4382 ||(sym->attr.flavor == FL_DERIVED
4383 && st->n.sym->attr.generic && st->n.sym->attr.function))
4384 goto fixup_contained;
4385
4386 old_sym = st->n.sym;
4387 if (old_sym->ns == ns
4388 && !old_sym->attr.contained
4389
4390 /* By 14.6.1.3, host association should be excluded
4391 for the following. */
4392 && !(old_sym->attr.external
4393 || (old_sym->ts.type != BT_UNKNOWN
4394 && !old_sym->attr.implicit_type)
4395 || old_sym->attr.flavor == FL_PARAMETER
4396 || old_sym->attr.use_assoc
4397 || old_sym->attr.in_common
4398 || old_sym->attr.in_equivalence
4399 || old_sym->attr.data
4400 || old_sym->attr.dummy
4401 || old_sym->attr.result
4402 || old_sym->attr.dimension
4403 || old_sym->attr.allocatable
4404 || old_sym->attr.intrinsic
4405 || old_sym->attr.generic
4406 || old_sym->attr.flavor == FL_NAMELIST
4407 || old_sym->attr.flavor == FL_LABEL
4408 || old_sym->attr.proc == PROC_ST_FUNCTION))
4409 {
4410 /* Replace it with the symbol from the parent namespace. */
4411 st->n.sym = sym;
4412 sym->refs++;
4413
4414 gfc_release_symbol (old_sym);
4415 }
4416
4417 fixup_contained:
4418 /* Do the same for any contained procedures. */
4419 gfc_fixup_sibling_symbols (sym, ns->contained);
4420 }
4421 }
4422
4423 static void
4424 parse_contained (int module)
4425 {
4426 gfc_namespace *ns, *parent_ns, *tmp;
4427 gfc_state_data s1, s2;
4428 gfc_statement st;
4429 gfc_symbol *sym;
4430 gfc_entry_list *el;
4431 int contains_statements = 0;
4432 int seen_error = 0;
4433
4434 push_state (&s1, COMP_CONTAINS, NULL);
4435 parent_ns = gfc_current_ns;
4436
4437 do
4438 {
4439 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
4440
4441 gfc_current_ns->sibling = parent_ns->contained;
4442 parent_ns->contained = gfc_current_ns;
4443
4444 next:
4445 /* Process the next available statement. We come here if we got an error
4446 and rejected the last statement. */
4447 st = next_statement ();
4448
4449 switch (st)
4450 {
4451 case ST_NONE:
4452 unexpected_eof ();
4453
4454 case ST_FUNCTION:
4455 case ST_SUBROUTINE:
4456 contains_statements = 1;
4457 accept_statement (st);
4458
4459 push_state (&s2,
4460 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
4461 gfc_new_block);
4462
4463 /* For internal procedures, create/update the symbol in the
4464 parent namespace. */
4465
4466 if (!module)
4467 {
4468 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
4469 gfc_error ("Contained procedure '%s' at %C is already "
4470 "ambiguous", gfc_new_block->name);
4471 else
4472 {
4473 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
4474 sym->name,
4475 &gfc_new_block->declared_at))
4476 {
4477 if (st == ST_FUNCTION)
4478 gfc_add_function (&sym->attr, sym->name,
4479 &gfc_new_block->declared_at);
4480 else
4481 gfc_add_subroutine (&sym->attr, sym->name,
4482 &gfc_new_block->declared_at);
4483 }
4484 }
4485
4486 gfc_commit_symbols ();
4487 }
4488 else
4489 sym = gfc_new_block;
4490
4491 /* Mark this as a contained function, so it isn't replaced
4492 by other module functions. */
4493 sym->attr.contained = 1;
4494
4495 /* Set implicit_pure so that it can be reset if any of the
4496 tests for purity fail. This is used for some optimisation
4497 during translation. */
4498 if (!sym->attr.pure)
4499 sym->attr.implicit_pure = 1;
4500
4501 parse_progunit (ST_NONE);
4502
4503 /* Fix up any sibling functions that refer to this one. */
4504 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
4505 /* Or refer to any of its alternate entry points. */
4506 for (el = gfc_current_ns->entries; el; el = el->next)
4507 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
4508
4509 gfc_current_ns->code = s2.head;
4510 gfc_current_ns = parent_ns;
4511
4512 pop_state ();
4513 break;
4514
4515 /* These statements are associated with the end of the host unit. */
4516 case ST_END_FUNCTION:
4517 case ST_END_MODULE:
4518 case ST_END_PROGRAM:
4519 case ST_END_SUBROUTINE:
4520 accept_statement (st);
4521 gfc_current_ns->code = s1.head;
4522 break;
4523
4524 default:
4525 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4526 gfc_ascii_statement (st));
4527 reject_statement ();
4528 seen_error = 1;
4529 goto next;
4530 break;
4531 }
4532 }
4533 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
4534 && st != ST_END_MODULE && st != ST_END_PROGRAM);
4535
4536 /* The first namespace in the list is guaranteed to not have
4537 anything (worthwhile) in it. */
4538 tmp = gfc_current_ns;
4539 gfc_current_ns = parent_ns;
4540 if (seen_error && tmp->refs > 1)
4541 gfc_free_namespace (tmp);
4542
4543 ns = gfc_current_ns->contained;
4544 gfc_current_ns->contained = ns->sibling;
4545 gfc_free_namespace (ns);
4546
4547 pop_state ();
4548 if (!contains_statements)
4549 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
4550 "FUNCTION or SUBROUTINE statement at %C");
4551 }
4552
4553
4554 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4555
4556 static void
4557 parse_progunit (gfc_statement st)
4558 {
4559 gfc_state_data *p;
4560 int n;
4561
4562 st = parse_spec (st);
4563 switch (st)
4564 {
4565 case ST_NONE:
4566 unexpected_eof ();
4567
4568 case ST_CONTAINS:
4569 /* This is not allowed within BLOCK! */
4570 if (gfc_current_state () != COMP_BLOCK)
4571 goto contains;
4572 break;
4573
4574 case_end:
4575 accept_statement (st);
4576 goto done;
4577
4578 default:
4579 break;
4580 }
4581
4582 if (gfc_current_state () == COMP_FUNCTION)
4583 gfc_check_function_type (gfc_current_ns);
4584
4585 loop:
4586 for (;;)
4587 {
4588 st = parse_executable (st);
4589
4590 switch (st)
4591 {
4592 case ST_NONE:
4593 unexpected_eof ();
4594
4595 case ST_CONTAINS:
4596 /* This is not allowed within BLOCK! */
4597 if (gfc_current_state () != COMP_BLOCK)
4598 goto contains;
4599 break;
4600
4601 case_end:
4602 accept_statement (st);
4603 goto done;
4604
4605 default:
4606 break;
4607 }
4608
4609 unexpected_statement (st);
4610 reject_statement ();
4611 st = next_statement ();
4612 }
4613
4614 contains:
4615 n = 0;
4616
4617 for (p = gfc_state_stack; p; p = p->previous)
4618 if (p->state == COMP_CONTAINS)
4619 n++;
4620
4621 if (gfc_find_state (COMP_MODULE) == true)
4622 n--;
4623
4624 if (n > 0)
4625 {
4626 gfc_error ("CONTAINS statement at %C is already in a contained "
4627 "program unit");
4628 reject_statement ();
4629 st = next_statement ();
4630 goto loop;
4631 }
4632
4633 parse_contained (0);
4634
4635 done:
4636 gfc_current_ns->code = gfc_state_stack->head;
4637 }
4638
4639
4640 /* Come here to complain about a global symbol already in use as
4641 something else. */
4642
4643 void
4644 gfc_global_used (gfc_gsymbol *sym, locus *where)
4645 {
4646 const char *name;
4647
4648 if (where == NULL)
4649 where = &gfc_current_locus;
4650
4651 switch(sym->type)
4652 {
4653 case GSYM_PROGRAM:
4654 name = "PROGRAM";
4655 break;
4656 case GSYM_FUNCTION:
4657 name = "FUNCTION";
4658 break;
4659 case GSYM_SUBROUTINE:
4660 name = "SUBROUTINE";
4661 break;
4662 case GSYM_COMMON:
4663 name = "COMMON";
4664 break;
4665 case GSYM_BLOCK_DATA:
4666 name = "BLOCK DATA";
4667 break;
4668 case GSYM_MODULE:
4669 name = "MODULE";
4670 break;
4671 default:
4672 gfc_internal_error ("gfc_global_used(): Bad type");
4673 name = NULL;
4674 }
4675
4676 if (sym->binding_label)
4677 gfc_error ("Global binding name '%s' at %L is already being used as a %s "
4678 "at %L", sym->binding_label, where, name, &sym->where);
4679 else
4680 gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
4681 sym->name, where, name, &sym->where);
4682 }
4683
4684
4685 /* Parse a block data program unit. */
4686
4687 static void
4688 parse_block_data (void)
4689 {
4690 gfc_statement st;
4691 static locus blank_locus;
4692 static int blank_block=0;
4693 gfc_gsymbol *s;
4694
4695 gfc_current_ns->proc_name = gfc_new_block;
4696 gfc_current_ns->is_block_data = 1;
4697
4698 if (gfc_new_block == NULL)
4699 {
4700 if (blank_block)
4701 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4702 "prior BLOCK DATA at %L", &blank_locus);
4703 else
4704 {
4705 blank_block = 1;
4706 blank_locus = gfc_current_locus;
4707 }
4708 }
4709 else
4710 {
4711 s = gfc_get_gsymbol (gfc_new_block->name);
4712 if (s->defined
4713 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4714 gfc_global_used (s, &gfc_new_block->declared_at);
4715 else
4716 {
4717 s->type = GSYM_BLOCK_DATA;
4718 s->where = gfc_new_block->declared_at;
4719 s->defined = 1;
4720 }
4721 }
4722
4723 st = parse_spec (ST_NONE);
4724
4725 while (st != ST_END_BLOCK_DATA)
4726 {
4727 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4728 gfc_ascii_statement (st));
4729 reject_statement ();
4730 st = next_statement ();
4731 }
4732 }
4733
4734
4735 /* Parse a module subprogram. */
4736
4737 static void
4738 parse_module (void)
4739 {
4740 gfc_statement st;
4741 gfc_gsymbol *s;
4742 bool error;
4743
4744 s = gfc_get_gsymbol (gfc_new_block->name);
4745 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4746 gfc_global_used (s, &gfc_new_block->declared_at);
4747 else
4748 {
4749 s->type = GSYM_MODULE;
4750 s->where = gfc_new_block->declared_at;
4751 s->defined = 1;
4752 }
4753
4754 st = parse_spec (ST_NONE);
4755
4756 error = false;
4757 loop:
4758 switch (st)
4759 {
4760 case ST_NONE:
4761 unexpected_eof ();
4762
4763 case ST_CONTAINS:
4764 parse_contained (1);
4765 break;
4766
4767 case ST_END_MODULE:
4768 accept_statement (st);
4769 break;
4770
4771 default:
4772 gfc_error ("Unexpected %s statement in MODULE at %C",
4773 gfc_ascii_statement (st));
4774
4775 error = true;
4776 reject_statement ();
4777 st = next_statement ();
4778 goto loop;
4779 }
4780
4781 /* Make sure not to free the namespace twice on error. */
4782 if (!error)
4783 s->ns = gfc_current_ns;
4784 }
4785
4786
4787 /* Add a procedure name to the global symbol table. */
4788
4789 static void
4790 add_global_procedure (bool sub)
4791 {
4792 gfc_gsymbol *s;
4793
4794 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
4795 name is a global identifier. */
4796 if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
4797 {
4798 s = gfc_get_gsymbol (gfc_new_block->name);
4799
4800 if (s->defined
4801 || (s->type != GSYM_UNKNOWN
4802 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4803 {
4804 gfc_global_used (s, &gfc_new_block->declared_at);
4805 /* Silence follow-up errors. */
4806 gfc_new_block->binding_label = NULL;
4807 }
4808 else
4809 {
4810 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4811 s->sym_name = gfc_new_block->name;
4812 s->where = gfc_new_block->declared_at;
4813 s->defined = 1;
4814 s->ns = gfc_current_ns;
4815 }
4816 }
4817
4818 /* Don't add the symbol multiple times. */
4819 if (gfc_new_block->binding_label
4820 && (!gfc_notification_std (GFC_STD_F2008)
4821 || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
4822 {
4823 s = gfc_get_gsymbol (gfc_new_block->binding_label);
4824
4825 if (s->defined
4826 || (s->type != GSYM_UNKNOWN
4827 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4828 {
4829 gfc_global_used (s, &gfc_new_block->declared_at);
4830 /* Silence follow-up errors. */
4831 gfc_new_block->binding_label = NULL;
4832 }
4833 else
4834 {
4835 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4836 s->sym_name = gfc_new_block->name;
4837 s->binding_label = gfc_new_block->binding_label;
4838 s->where = gfc_new_block->declared_at;
4839 s->defined = 1;
4840 s->ns = gfc_current_ns;
4841 }
4842 }
4843 }
4844
4845
4846 /* Add a program to the global symbol table. */
4847
4848 static void
4849 add_global_program (void)
4850 {
4851 gfc_gsymbol *s;
4852
4853 if (gfc_new_block == NULL)
4854 return;
4855 s = gfc_get_gsymbol (gfc_new_block->name);
4856
4857 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4858 gfc_global_used (s, &gfc_new_block->declared_at);
4859 else
4860 {
4861 s->type = GSYM_PROGRAM;
4862 s->where = gfc_new_block->declared_at;
4863 s->defined = 1;
4864 s->ns = gfc_current_ns;
4865 }
4866 }
4867
4868
4869 /* Resolve all the program units. */
4870 static void
4871 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4872 {
4873 gfc_free_dt_list ();
4874 gfc_current_ns = gfc_global_ns_list;
4875 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4876 {
4877 if (gfc_current_ns->proc_name
4878 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4879 continue; /* Already resolved. */
4880
4881 if (gfc_current_ns->proc_name)
4882 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4883 gfc_resolve (gfc_current_ns);
4884 gfc_current_ns->derived_types = gfc_derived_types;
4885 gfc_derived_types = NULL;
4886 }
4887 }
4888
4889
4890 static void
4891 clean_up_modules (gfc_gsymbol *gsym)
4892 {
4893 if (gsym == NULL)
4894 return;
4895
4896 clean_up_modules (gsym->left);
4897 clean_up_modules (gsym->right);
4898
4899 if (gsym->type != GSYM_MODULE || !gsym->ns)
4900 return;
4901
4902 gfc_current_ns = gsym->ns;
4903 gfc_derived_types = gfc_current_ns->derived_types;
4904 gfc_done_2 ();
4905 gsym->ns = NULL;
4906 return;
4907 }
4908
4909
4910 /* Translate all the program units. This could be in a different order
4911 to resolution if there are forward references in the file. */
4912 static void
4913 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4914 {
4915 int errors;
4916
4917 gfc_current_ns = gfc_global_ns_list;
4918 gfc_get_errors (NULL, &errors);
4919
4920 /* We first translate all modules to make sure that later parts
4921 of the program can use the decl. Then we translate the nonmodules. */
4922
4923 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4924 {
4925 if (!gfc_current_ns->proc_name
4926 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4927 continue;
4928
4929 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4930 gfc_derived_types = gfc_current_ns->derived_types;
4931 gfc_generate_module_code (gfc_current_ns);
4932 gfc_current_ns->translated = 1;
4933 }
4934
4935 gfc_current_ns = gfc_global_ns_list;
4936 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4937 {
4938 if (gfc_current_ns->proc_name
4939 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4940 continue;
4941
4942 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4943 gfc_derived_types = gfc_current_ns->derived_types;
4944 gfc_generate_code (gfc_current_ns);
4945 gfc_current_ns->translated = 1;
4946 }
4947
4948 /* Clean up all the namespaces after translation. */
4949 gfc_current_ns = gfc_global_ns_list;
4950 for (;gfc_current_ns;)
4951 {
4952 gfc_namespace *ns;
4953
4954 if (gfc_current_ns->proc_name
4955 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4956 {
4957 gfc_current_ns = gfc_current_ns->sibling;
4958 continue;
4959 }
4960
4961 ns = gfc_current_ns->sibling;
4962 gfc_derived_types = gfc_current_ns->derived_types;
4963 gfc_done_2 ();
4964 gfc_current_ns = ns;
4965 }
4966
4967 clean_up_modules (gfc_gsym_root);
4968 }
4969
4970
4971 /* Top level parser. */
4972
4973 bool
4974 gfc_parse_file (void)
4975 {
4976 int seen_program, errors_before, errors;
4977 gfc_state_data top, s;
4978 gfc_statement st;
4979 locus prog_locus;
4980 gfc_namespace *next;
4981
4982 gfc_start_source_files ();
4983
4984 top.state = COMP_NONE;
4985 top.sym = NULL;
4986 top.previous = NULL;
4987 top.head = top.tail = NULL;
4988 top.do_variable = NULL;
4989
4990 gfc_state_stack = &top;
4991
4992 gfc_clear_new_st ();
4993
4994 gfc_statement_label = NULL;
4995
4996 if (setjmp (eof_buf))
4997 return false; /* Come here on unexpected EOF */
4998
4999 /* Prepare the global namespace that will contain the
5000 program units. */
5001 gfc_global_ns_list = next = NULL;
5002
5003 seen_program = 0;
5004 errors_before = 0;
5005
5006 /* Exit early for empty files. */
5007 if (gfc_at_eof ())
5008 goto done;
5009
5010 loop:
5011 gfc_init_2 ();
5012 st = next_statement ();
5013 switch (st)
5014 {
5015 case ST_NONE:
5016 gfc_done_2 ();
5017 goto done;
5018
5019 case ST_PROGRAM:
5020 if (seen_program)
5021 goto duplicate_main;
5022 seen_program = 1;
5023 prog_locus = gfc_current_locus;
5024
5025 push_state (&s, COMP_PROGRAM, gfc_new_block);
5026 main_program_symbol(gfc_current_ns, gfc_new_block->name);
5027 accept_statement (st);
5028 add_global_program ();
5029 parse_progunit (ST_NONE);
5030 goto prog_units;
5031 break;
5032
5033 case ST_SUBROUTINE:
5034 add_global_procedure (true);
5035 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
5036 accept_statement (st);
5037 parse_progunit (ST_NONE);
5038 goto prog_units;
5039 break;
5040
5041 case ST_FUNCTION:
5042 add_global_procedure (false);
5043 push_state (&s, COMP_FUNCTION, gfc_new_block);
5044 accept_statement (st);
5045 parse_progunit (ST_NONE);
5046 goto prog_units;
5047 break;
5048
5049 case ST_BLOCK_DATA:
5050 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
5051 accept_statement (st);
5052 parse_block_data ();
5053 break;
5054
5055 case ST_MODULE:
5056 push_state (&s, COMP_MODULE, gfc_new_block);
5057 accept_statement (st);
5058
5059 gfc_get_errors (NULL, &errors_before);
5060 parse_module ();
5061 break;
5062
5063 /* Anything else starts a nameless main program block. */
5064 default:
5065 if (seen_program)
5066 goto duplicate_main;
5067 seen_program = 1;
5068 prog_locus = gfc_current_locus;
5069
5070 push_state (&s, COMP_PROGRAM, gfc_new_block);
5071 main_program_symbol (gfc_current_ns, "MAIN__");
5072 parse_progunit (st);
5073 goto prog_units;
5074 break;
5075 }
5076
5077 /* Handle the non-program units. */
5078 gfc_current_ns->code = s.head;
5079
5080 gfc_resolve (gfc_current_ns);
5081
5082 /* Dump the parse tree if requested. */
5083 if (gfc_option.dump_fortran_original)
5084 gfc_dump_parse_tree (gfc_current_ns, stdout);
5085
5086 gfc_get_errors (NULL, &errors);
5087 if (s.state == COMP_MODULE)
5088 {
5089 gfc_dump_module (s.sym->name, errors_before == errors);
5090 gfc_current_ns->derived_types = gfc_derived_types;
5091 gfc_derived_types = NULL;
5092 goto prog_units;
5093 }
5094 else
5095 {
5096 if (errors == 0)
5097 gfc_generate_code (gfc_current_ns);
5098 pop_state ();
5099 gfc_done_2 ();
5100 }
5101
5102 goto loop;
5103
5104 prog_units:
5105 /* The main program and non-contained procedures are put
5106 in the global namespace list, so that they can be processed
5107 later and all their interfaces resolved. */
5108 gfc_current_ns->code = s.head;
5109 if (next)
5110 {
5111 for (; next->sibling; next = next->sibling)
5112 ;
5113 next->sibling = gfc_current_ns;
5114 }
5115 else
5116 gfc_global_ns_list = gfc_current_ns;
5117
5118 next = gfc_current_ns;
5119
5120 pop_state ();
5121 goto loop;
5122
5123 done:
5124
5125 /* Do the resolution. */
5126 resolve_all_program_units (gfc_global_ns_list);
5127
5128 /* Do the parse tree dump. */
5129 gfc_current_ns
5130 = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
5131
5132 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
5133 if (!gfc_current_ns->proc_name
5134 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5135 {
5136 gfc_dump_parse_tree (gfc_current_ns, stdout);
5137 fputs ("------------------------------------------\n\n", stdout);
5138 }
5139
5140 /* Do the translation. */
5141 translate_all_program_units (gfc_global_ns_list);
5142
5143 gfc_end_source_files ();
5144 return true;
5145
5146 duplicate_main:
5147 /* If we see a duplicate main program, shut down. If the second
5148 instance is an implied main program, i.e. data decls or executable
5149 statements, we're in for lots of errors. */
5150 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
5151 reject_statement ();
5152 gfc_done_2 ();
5153 return true;
5154 }