?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2014-07-12 Paul Thomas <pault@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / parse.c
blobe8dcb70edb243afff9e180b332220456a15a3e27
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 ("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 ("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 ("Too many digits in statement label at %C");
840
841 if (i == 0)
842 gfc_error_now ("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 ("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 ("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 ("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 ("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 gfc_set_implicit_none ();
1954 break;
1955
1956 case ST_IMPLICIT:
1957 break;
1958
1959 case ST_FUNCTION:
1960 case ST_SUBROUTINE:
1961 case ST_MODULE:
1962 gfc_current_ns->proc_name = gfc_new_block;
1963 break;
1964
1965 /* If the statement is the end of a block, lay down a special code
1966 that allows a branch to the end of the block from within the
1967 construct. IF and SELECT are treated differently from DO
1968 (where EXEC_NOP is added inside the loop) for two
1969 reasons:
1970 1. END DO has a meaning in the sense that after a GOTO to
1971 it, the loop counter must be increased.
1972 2. IF blocks and SELECT blocks can consist of multiple
1973 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1974 Putting the label before the END IF would make the jump
1975 from, say, the ELSE IF block to the END IF illegal. */
1976
1977 case ST_ENDIF:
1978 case ST_END_SELECT:
1979 case ST_END_CRITICAL:
1980 if (gfc_statement_label != NULL)
1981 {
1982 new_st.op = EXEC_END_NESTED_BLOCK;
1983 add_statement ();
1984 }
1985 break;
1986
1987 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
1988 one parallel block. Thus, we add the special code to the nested block
1989 itself, instead of the parent one. */
1990 case ST_END_BLOCK:
1991 case ST_END_ASSOCIATE:
1992 if (gfc_statement_label != NULL)
1993 {
1994 new_st.op = EXEC_END_BLOCK;
1995 add_statement ();
1996 }
1997 break;
1998
1999 /* The end-of-program unit statements do not get the special
2000 marker and require a statement of some sort if they are a
2001 branch target. */
2002
2003 case ST_END_PROGRAM:
2004 case ST_END_FUNCTION:
2005 case ST_END_SUBROUTINE:
2006 if (gfc_statement_label != NULL)
2007 {
2008 new_st.op = EXEC_RETURN;
2009 add_statement ();
2010 }
2011 else
2012 {
2013 new_st.op = EXEC_END_PROCEDURE;
2014 add_statement ();
2015 }
2016
2017 break;
2018
2019 case ST_ENTRY:
2020 case_executable:
2021 case_exec_markers:
2022 add_statement ();
2023 break;
2024
2025 default:
2026 break;
2027 }
2028
2029 gfc_commit_symbols ();
2030 gfc_warning_check ();
2031 gfc_clear_new_st ();
2032 }
2033
2034
2035 /* Undo anything tentative that has been built for the current
2036 statement. */
2037
2038 static void
2039 reject_statement (void)
2040 {
2041 /* Revert to the previous charlen chain. */
2042 gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
2043 gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
2044
2045 gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
2046 gfc_current_ns->equiv = gfc_current_ns->old_equiv;
2047
2048 gfc_new_block = NULL;
2049 gfc_undo_symbols ();
2050 gfc_clear_warning ();
2051 undo_new_statement ();
2052 }
2053
2054
2055 /* Generic complaint about an out of order statement. We also do
2056 whatever is necessary to clean up. */
2057
2058 static void
2059 unexpected_statement (gfc_statement st)
2060 {
2061 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
2062
2063 reject_statement ();
2064 }
2065
2066
2067 /* Given the next statement seen by the matcher, make sure that it is
2068 in proper order with the last. This subroutine is initialized by
2069 calling it with an argument of ST_NONE. If there is a problem, we
2070 issue an error and return false. Otherwise we return true.
2071
2072 Individual parsers need to verify that the statements seen are
2073 valid before calling here, i.e., ENTRY statements are not allowed in
2074 INTERFACE blocks. The following diagram is taken from the standard:
2075
2076 +---------------------------------------+
2077 | program subroutine function module |
2078 +---------------------------------------+
2079 | use |
2080 +---------------------------------------+
2081 | import |
2082 +---------------------------------------+
2083 | | implicit none |
2084 | +-----------+------------------+
2085 | | parameter | implicit |
2086 | +-----------+------------------+
2087 | format | | derived type |
2088 | entry | parameter | interface |
2089 | | data | specification |
2090 | | | statement func |
2091 | +-----------+------------------+
2092 | | data | executable |
2093 +--------+-----------+------------------+
2094 | contains |
2095 +---------------------------------------+
2096 | internal module/subprogram |
2097 +---------------------------------------+
2098 | end |
2099 +---------------------------------------+
2100
2101 */
2102
2103 enum state_order
2104 {
2105 ORDER_START,
2106 ORDER_USE,
2107 ORDER_IMPORT,
2108 ORDER_IMPLICIT_NONE,
2109 ORDER_IMPLICIT,
2110 ORDER_SPEC,
2111 ORDER_EXEC
2112 };
2113
2114 typedef struct
2115 {
2116 enum state_order state;
2117 gfc_statement last_statement;
2118 locus where;
2119 }
2120 st_state;
2121
2122 static bool
2123 verify_st_order (st_state *p, gfc_statement st, bool silent)
2124 {
2125
2126 switch (st)
2127 {
2128 case ST_NONE:
2129 p->state = ORDER_START;
2130 break;
2131
2132 case ST_USE:
2133 if (p->state > ORDER_USE)
2134 goto order;
2135 p->state = ORDER_USE;
2136 break;
2137
2138 case ST_IMPORT:
2139 if (p->state > ORDER_IMPORT)
2140 goto order;
2141 p->state = ORDER_IMPORT;
2142 break;
2143
2144 case ST_IMPLICIT_NONE:
2145 if (p->state > ORDER_IMPLICIT_NONE)
2146 goto order;
2147
2148 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2149 statement disqualifies a USE but not an IMPLICIT NONE.
2150 Duplicate IMPLICIT NONEs are caught when the implicit types
2151 are set. */
2152
2153 p->state = ORDER_IMPLICIT_NONE;
2154 break;
2155
2156 case ST_IMPLICIT:
2157 if (p->state > ORDER_IMPLICIT)
2158 goto order;
2159 p->state = ORDER_IMPLICIT;
2160 break;
2161
2162 case ST_FORMAT:
2163 case ST_ENTRY:
2164 if (p->state < ORDER_IMPLICIT_NONE)
2165 p->state = ORDER_IMPLICIT_NONE;
2166 break;
2167
2168 case ST_PARAMETER:
2169 if (p->state >= ORDER_EXEC)
2170 goto order;
2171 if (p->state < ORDER_IMPLICIT)
2172 p->state = ORDER_IMPLICIT;
2173 break;
2174
2175 case ST_DATA:
2176 if (p->state < ORDER_SPEC)
2177 p->state = ORDER_SPEC;
2178 break;
2179
2180 case ST_PUBLIC:
2181 case ST_PRIVATE:
2182 case ST_DERIVED_DECL:
2183 case_decl:
2184 if (p->state >= ORDER_EXEC)
2185 goto order;
2186 if (p->state < ORDER_SPEC)
2187 p->state = ORDER_SPEC;
2188 break;
2189
2190 case_executable:
2191 case_exec_markers:
2192 if (p->state < ORDER_EXEC)
2193 p->state = ORDER_EXEC;
2194 break;
2195
2196 default:
2197 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
2198 gfc_ascii_statement (st));
2199 }
2200
2201 /* All is well, record the statement in case we need it next time. */
2202 p->where = gfc_current_locus;
2203 p->last_statement = st;
2204 return true;
2205
2206 order:
2207 if (!silent)
2208 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2209 gfc_ascii_statement (st),
2210 gfc_ascii_statement (p->last_statement), &p->where);
2211
2212 return false;
2213 }
2214
2215
2216 /* Handle an unexpected end of file. This is a show-stopper... */
2217
2218 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
2219
2220 static void
2221 unexpected_eof (void)
2222 {
2223 gfc_state_data *p;
2224
2225 gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
2226
2227 /* Memory cleanup. Move to "second to last". */
2228 for (p = gfc_state_stack; p && p->previous && p->previous->previous;
2229 p = p->previous);
2230
2231 gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
2232 gfc_done_2 ();
2233
2234 longjmp (eof_buf, 1);
2235 }
2236
2237
2238 /* Parse the CONTAINS section of a derived type definition. */
2239
2240 gfc_access gfc_typebound_default_access;
2241
2242 static bool
2243 parse_derived_contains (void)
2244 {
2245 gfc_state_data s;
2246 bool seen_private = false;
2247 bool seen_comps = false;
2248 bool error_flag = false;
2249 bool to_finish;
2250
2251 gcc_assert (gfc_current_state () == COMP_DERIVED);
2252 gcc_assert (gfc_current_block ());
2253
2254 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2255 section. */
2256 if (gfc_current_block ()->attr.sequence)
2257 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
2258 " section at %C", gfc_current_block ()->name);
2259 if (gfc_current_block ()->attr.is_bind_c)
2260 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
2261 " section at %C", gfc_current_block ()->name);
2262
2263 accept_statement (ST_CONTAINS);
2264 push_state (&s, COMP_DERIVED_CONTAINS, NULL);
2265
2266 gfc_typebound_default_access = ACCESS_PUBLIC;
2267
2268 to_finish = false;
2269 while (!to_finish)
2270 {
2271 gfc_statement st;
2272 st = next_statement ();
2273 switch (st)
2274 {
2275 case ST_NONE:
2276 unexpected_eof ();
2277 break;
2278
2279 case ST_DATA_DECL:
2280 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2281 goto error;
2282
2283 case ST_PROCEDURE:
2284 if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
2285 goto error;
2286
2287 accept_statement (ST_PROCEDURE);
2288 seen_comps = true;
2289 break;
2290
2291 case ST_GENERIC:
2292 if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
2293 goto error;
2294
2295 accept_statement (ST_GENERIC);
2296 seen_comps = true;
2297 break;
2298
2299 case ST_FINAL:
2300 if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
2301 " at %C"))
2302 goto error;
2303
2304 accept_statement (ST_FINAL);
2305 seen_comps = true;
2306 break;
2307
2308 case ST_END_TYPE:
2309 to_finish = true;
2310
2311 if (!seen_comps
2312 && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
2313 "at %C with empty CONTAINS section")))
2314 goto error;
2315
2316 /* ST_END_TYPE is accepted by parse_derived after return. */
2317 break;
2318
2319 case ST_PRIVATE:
2320 if (!gfc_find_state (COMP_MODULE))
2321 {
2322 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2323 "a MODULE");
2324 goto error;
2325 }
2326
2327 if (seen_comps)
2328 {
2329 gfc_error ("PRIVATE statement at %C must precede procedure"
2330 " bindings");
2331 goto error;
2332 }
2333
2334 if (seen_private)
2335 {
2336 gfc_error ("Duplicate PRIVATE statement at %C");
2337 goto error;
2338 }
2339
2340 accept_statement (ST_PRIVATE);
2341 gfc_typebound_default_access = ACCESS_PRIVATE;
2342 seen_private = true;
2343 break;
2344
2345 case ST_SEQUENCE:
2346 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2347 goto error;
2348
2349 case ST_CONTAINS:
2350 gfc_error ("Already inside a CONTAINS block at %C");
2351 goto error;
2352
2353 default:
2354 unexpected_statement (st);
2355 break;
2356 }
2357
2358 continue;
2359
2360 error:
2361 error_flag = true;
2362 reject_statement ();
2363 }
2364
2365 pop_state ();
2366 gcc_assert (gfc_current_state () == COMP_DERIVED);
2367
2368 return error_flag;
2369 }
2370
2371
2372 /* Parse a derived type. */
2373
2374 static void
2375 parse_derived (void)
2376 {
2377 int compiling_type, seen_private, seen_sequence, seen_component;
2378 gfc_statement st;
2379 gfc_state_data s;
2380 gfc_symbol *sym;
2381 gfc_component *c, *lock_comp = NULL;
2382
2383 accept_statement (ST_DERIVED_DECL);
2384 push_state (&s, COMP_DERIVED, gfc_new_block);
2385
2386 gfc_new_block->component_access = ACCESS_PUBLIC;
2387 seen_private = 0;
2388 seen_sequence = 0;
2389 seen_component = 0;
2390
2391 compiling_type = 1;
2392
2393 while (compiling_type)
2394 {
2395 st = next_statement ();
2396 switch (st)
2397 {
2398 case ST_NONE:
2399 unexpected_eof ();
2400
2401 case ST_DATA_DECL:
2402 case ST_PROCEDURE:
2403 accept_statement (st);
2404 seen_component = 1;
2405 break;
2406
2407 case ST_FINAL:
2408 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2409 break;
2410
2411 case ST_END_TYPE:
2412 endType:
2413 compiling_type = 0;
2414
2415 if (!seen_component)
2416 gfc_notify_std (GFC_STD_F2003, "Derived type "
2417 "definition at %C without components");
2418
2419 accept_statement (ST_END_TYPE);
2420 break;
2421
2422 case ST_PRIVATE:
2423 if (!gfc_find_state (COMP_MODULE))
2424 {
2425 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2426 "a MODULE");
2427 break;
2428 }
2429
2430 if (seen_component)
2431 {
2432 gfc_error ("PRIVATE statement at %C must precede "
2433 "structure components");
2434 break;
2435 }
2436
2437 if (seen_private)
2438 gfc_error ("Duplicate PRIVATE statement at %C");
2439
2440 s.sym->component_access = ACCESS_PRIVATE;
2441
2442 accept_statement (ST_PRIVATE);
2443 seen_private = 1;
2444 break;
2445
2446 case ST_SEQUENCE:
2447 if (seen_component)
2448 {
2449 gfc_error ("SEQUENCE statement at %C must precede "
2450 "structure components");
2451 break;
2452 }
2453
2454 if (gfc_current_block ()->attr.sequence)
2455 gfc_warning ("SEQUENCE attribute at %C already specified in "
2456 "TYPE statement");
2457
2458 if (seen_sequence)
2459 {
2460 gfc_error ("Duplicate SEQUENCE statement at %C");
2461 }
2462
2463 seen_sequence = 1;
2464 gfc_add_sequence (&gfc_current_block ()->attr,
2465 gfc_current_block ()->name, NULL);
2466 break;
2467
2468 case ST_CONTAINS:
2469 gfc_notify_std (GFC_STD_F2003,
2470 "CONTAINS block in derived type"
2471 " definition at %C");
2472
2473 accept_statement (ST_CONTAINS);
2474 parse_derived_contains ();
2475 goto endType;
2476
2477 default:
2478 unexpected_statement (st);
2479 break;
2480 }
2481 }
2482
2483 /* need to verify that all fields of the derived type are
2484 * interoperable with C if the type is declared to be bind(c)
2485 */
2486 sym = gfc_current_block ();
2487 for (c = sym->components; c; c = c->next)
2488 {
2489 bool coarray, lock_type, allocatable, pointer;
2490 coarray = lock_type = allocatable = pointer = false;
2491
2492 /* Look for allocatable components. */
2493 if (c->attr.allocatable
2494 || (c->ts.type == BT_CLASS && c->attr.class_ok
2495 && CLASS_DATA (c)->attr.allocatable)
2496 || (c->ts.type == BT_DERIVED && !c->attr.pointer
2497 && c->ts.u.derived->attr.alloc_comp))
2498 {
2499 allocatable = true;
2500 sym->attr.alloc_comp = 1;
2501 }
2502
2503 /* Look for pointer components. */
2504 if (c->attr.pointer
2505 || (c->ts.type == BT_CLASS && c->attr.class_ok
2506 && CLASS_DATA (c)->attr.class_pointer)
2507 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2508 {
2509 pointer = true;
2510 sym->attr.pointer_comp = 1;
2511 }
2512
2513 /* Look for procedure pointer components. */
2514 if (c->attr.proc_pointer
2515 || (c->ts.type == BT_DERIVED
2516 && c->ts.u.derived->attr.proc_pointer_comp))
2517 sym->attr.proc_pointer_comp = 1;
2518
2519 /* Looking for coarray components. */
2520 if (c->attr.codimension
2521 || (c->ts.type == BT_CLASS && c->attr.class_ok
2522 && CLASS_DATA (c)->attr.codimension))
2523 {
2524 coarray = true;
2525 sym->attr.coarray_comp = 1;
2526 }
2527
2528 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
2529 && !c->attr.pointer)
2530 {
2531 coarray = true;
2532 sym->attr.coarray_comp = 1;
2533 }
2534
2535 /* Looking for lock_type components. */
2536 if ((c->ts.type == BT_DERIVED
2537 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2538 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2539 || (c->ts.type == BT_CLASS && c->attr.class_ok
2540 && CLASS_DATA (c)->ts.u.derived->from_intmod
2541 == INTMOD_ISO_FORTRAN_ENV
2542 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
2543 == ISOFORTRAN_LOCK_TYPE)
2544 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
2545 && !allocatable && !pointer))
2546 {
2547 lock_type = 1;
2548 lock_comp = c;
2549 sym->attr.lock_comp = 1;
2550 }
2551
2552 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2553 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2554 unless there are nondirect [allocatable or pointer] components
2555 involved (cf. 1.3.33.1 and 1.3.33.3). */
2556
2557 if (pointer && !coarray && lock_type)
2558 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2559 "codimension or be a subcomponent of a coarray, "
2560 "which is not possible as the component has the "
2561 "pointer attribute", c->name, &c->loc);
2562 else if (pointer && !coarray && c->ts.type == BT_DERIVED
2563 && c->ts.u.derived->attr.lock_comp)
2564 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2565 "of type LOCK_TYPE, which must have a codimension or be a "
2566 "subcomponent of a coarray", c->name, &c->loc);
2567
2568 if (lock_type && allocatable && !coarray)
2569 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2570 "a codimension", c->name, &c->loc);
2571 else if (lock_type && allocatable && c->ts.type == BT_DERIVED
2572 && c->ts.u.derived->attr.lock_comp)
2573 gfc_error ("Allocatable component %s at %L must have a codimension as "
2574 "it has a noncoarray subcomponent of type LOCK_TYPE",
2575 c->name, &c->loc);
2576
2577 if (sym->attr.coarray_comp && !coarray && lock_type)
2578 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2579 "subcomponent of type LOCK_TYPE must have a codimension or "
2580 "be a subcomponent of a coarray. (Variables of type %s may "
2581 "not have a codimension as already a coarray "
2582 "subcomponent exists)", c->name, &c->loc, sym->name);
2583
2584 if (sym->attr.lock_comp && coarray && !lock_type)
2585 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2586 "subcomponent of type LOCK_TYPE must have a codimension or "
2587 "be a subcomponent of a coarray. (Variables of type %s may "
2588 "not have a codimension as %s at %L has a codimension or a "
2589 "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
2590 sym->name, c->name, &c->loc);
2591
2592 /* Look for private components. */
2593 if (sym->component_access == ACCESS_PRIVATE
2594 || c->attr.access == ACCESS_PRIVATE
2595 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2596 sym->attr.private_comp = 1;
2597 }
2598
2599 if (!seen_component)
2600 sym->attr.zero_comp = 1;
2601
2602 pop_state ();
2603 }
2604
2605
2606 /* Parse an ENUM. */
2607
2608 static void
2609 parse_enum (void)
2610 {
2611 gfc_statement st;
2612 int compiling_enum;
2613 gfc_state_data s;
2614 int seen_enumerator = 0;
2615
2616 push_state (&s, COMP_ENUM, gfc_new_block);
2617
2618 compiling_enum = 1;
2619
2620 while (compiling_enum)
2621 {
2622 st = next_statement ();
2623 switch (st)
2624 {
2625 case ST_NONE:
2626 unexpected_eof ();
2627 break;
2628
2629 case ST_ENUMERATOR:
2630 seen_enumerator = 1;
2631 accept_statement (st);
2632 break;
2633
2634 case ST_END_ENUM:
2635 compiling_enum = 0;
2636 if (!seen_enumerator)
2637 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2638 accept_statement (st);
2639 break;
2640
2641 default:
2642 gfc_free_enum_history ();
2643 unexpected_statement (st);
2644 break;
2645 }
2646 }
2647 pop_state ();
2648 }
2649
2650
2651 /* Parse an interface. We must be able to deal with the possibility
2652 of recursive interfaces. The parse_spec() subroutine is mutually
2653 recursive with parse_interface(). */
2654
2655 static gfc_statement parse_spec (gfc_statement);
2656
2657 static void
2658 parse_interface (void)
2659 {
2660 gfc_compile_state new_state = COMP_NONE, current_state;
2661 gfc_symbol *prog_unit, *sym;
2662 gfc_interface_info save;
2663 gfc_state_data s1, s2;
2664 gfc_statement st;
2665
2666 accept_statement (ST_INTERFACE);
2667
2668 current_interface.ns = gfc_current_ns;
2669 save = current_interface;
2670
2671 sym = (current_interface.type == INTERFACE_GENERIC
2672 || current_interface.type == INTERFACE_USER_OP)
2673 ? gfc_new_block : NULL;
2674
2675 push_state (&s1, COMP_INTERFACE, sym);
2676 current_state = COMP_NONE;
2677
2678 loop:
2679 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2680
2681 st = next_statement ();
2682 switch (st)
2683 {
2684 case ST_NONE:
2685 unexpected_eof ();
2686
2687 case ST_SUBROUTINE:
2688 case ST_FUNCTION:
2689 if (st == ST_SUBROUTINE)
2690 new_state = COMP_SUBROUTINE;
2691 else if (st == ST_FUNCTION)
2692 new_state = COMP_FUNCTION;
2693 if (gfc_new_block->attr.pointer)
2694 {
2695 gfc_new_block->attr.pointer = 0;
2696 gfc_new_block->attr.proc_pointer = 1;
2697 }
2698 if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2699 gfc_new_block->formal, NULL))
2700 {
2701 reject_statement ();
2702 gfc_free_namespace (gfc_current_ns);
2703 goto loop;
2704 }
2705 break;
2706
2707 case ST_PROCEDURE:
2708 case ST_MODULE_PROC: /* The module procedure matcher makes
2709 sure the context is correct. */
2710 accept_statement (st);
2711 gfc_free_namespace (gfc_current_ns);
2712 goto loop;
2713
2714 case ST_END_INTERFACE:
2715 gfc_free_namespace (gfc_current_ns);
2716 gfc_current_ns = current_interface.ns;
2717 goto done;
2718
2719 default:
2720 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2721 gfc_ascii_statement (st));
2722 reject_statement ();
2723 gfc_free_namespace (gfc_current_ns);
2724 goto loop;
2725 }
2726
2727
2728 /* Make sure that the generic name has the right attribute. */
2729 if (current_interface.type == INTERFACE_GENERIC
2730 && current_state == COMP_NONE)
2731 {
2732 if (new_state == COMP_FUNCTION && sym)
2733 gfc_add_function (&sym->attr, sym->name, NULL);
2734 else if (new_state == COMP_SUBROUTINE && sym)
2735 gfc_add_subroutine (&sym->attr, sym->name, NULL);
2736
2737 current_state = new_state;
2738 }
2739
2740 if (current_interface.type == INTERFACE_ABSTRACT)
2741 {
2742 gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2743 if (gfc_is_intrinsic_typename (gfc_new_block->name))
2744 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2745 "cannot be the same as an intrinsic type",
2746 gfc_new_block->name);
2747 }
2748
2749 push_state (&s2, new_state, gfc_new_block);
2750 accept_statement (st);
2751 prog_unit = gfc_new_block;
2752 prog_unit->formal_ns = gfc_current_ns;
2753 if (prog_unit == prog_unit->formal_ns->proc_name
2754 && prog_unit->ns != prog_unit->formal_ns)
2755 prog_unit->refs++;
2756
2757 decl:
2758 /* Read data declaration statements. */
2759 st = parse_spec (ST_NONE);
2760
2761 /* Since the interface block does not permit an IMPLICIT statement,
2762 the default type for the function or the result must be taken
2763 from the formal namespace. */
2764 if (new_state == COMP_FUNCTION)
2765 {
2766 if (prog_unit->result == prog_unit
2767 && prog_unit->ts.type == BT_UNKNOWN)
2768 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2769 else if (prog_unit->result != prog_unit
2770 && prog_unit->result->ts.type == BT_UNKNOWN)
2771 gfc_set_default_type (prog_unit->result, 1,
2772 prog_unit->formal_ns);
2773 }
2774
2775 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2776 {
2777 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2778 gfc_ascii_statement (st));
2779 reject_statement ();
2780 goto decl;
2781 }
2782
2783 /* Add EXTERNAL attribute to function or subroutine. */
2784 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2785 gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2786
2787 current_interface = save;
2788 gfc_add_interface (prog_unit);
2789 pop_state ();
2790
2791 if (current_interface.ns
2792 && current_interface.ns->proc_name
2793 && strcmp (current_interface.ns->proc_name->name,
2794 prog_unit->name) == 0)
2795 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2796 "enclosing procedure", prog_unit->name,
2797 &current_interface.ns->proc_name->declared_at);
2798
2799 goto loop;
2800
2801 done:
2802 pop_state ();
2803 }
2804
2805
2806 /* Associate function characteristics by going back to the function
2807 declaration and rematching the prefix. */
2808
2809 static match
2810 match_deferred_characteristics (gfc_typespec * ts)
2811 {
2812 locus loc;
2813 match m = MATCH_ERROR;
2814 char name[GFC_MAX_SYMBOL_LEN + 1];
2815
2816 loc = gfc_current_locus;
2817
2818 gfc_current_locus = gfc_current_block ()->declared_at;
2819
2820 gfc_clear_error ();
2821 gfc_buffer_error (1);
2822 m = gfc_match_prefix (ts);
2823 gfc_buffer_error (0);
2824
2825 if (ts->type == BT_DERIVED)
2826 {
2827 ts->kind = 0;
2828
2829 if (!ts->u.derived)
2830 m = MATCH_ERROR;
2831 }
2832
2833 /* Only permit one go at the characteristic association. */
2834 if (ts->kind == -1)
2835 ts->kind = 0;
2836
2837 /* Set the function locus correctly. If we have not found the
2838 function name, there is an error. */
2839 if (m == MATCH_YES
2840 && gfc_match ("function% %n", name) == MATCH_YES
2841 && strcmp (name, gfc_current_block ()->name) == 0)
2842 {
2843 gfc_current_block ()->declared_at = gfc_current_locus;
2844 gfc_commit_symbols ();
2845 }
2846 else
2847 {
2848 gfc_error_check ();
2849 gfc_undo_symbols ();
2850 }
2851
2852 gfc_current_locus =loc;
2853 return m;
2854 }
2855
2856
2857 /* Check specification-expressions in the function result of the currently
2858 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2859 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2860 scope are not yet parsed so this has to be delayed up to parse_spec. */
2861
2862 static void
2863 check_function_result_typed (void)
2864 {
2865 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2866
2867 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2868 gcc_assert (ts->type != BT_UNKNOWN);
2869
2870 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2871 /* TODO: Extend when KIND type parameters are implemented. */
2872 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2873 gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2874 }
2875
2876
2877 /* Parse a set of specification statements. Returns the statement
2878 that doesn't fit. */
2879
2880 static gfc_statement
2881 parse_spec (gfc_statement st)
2882 {
2883 st_state ss;
2884 bool function_result_typed = false;
2885 bool bad_characteristic = false;
2886 gfc_typespec *ts;
2887
2888 verify_st_order (&ss, ST_NONE, false);
2889 if (st == ST_NONE)
2890 st = next_statement ();
2891
2892 /* If we are not inside a function or don't have a result specified so far,
2893 do nothing special about it. */
2894 if (gfc_current_state () != COMP_FUNCTION)
2895 function_result_typed = true;
2896 else
2897 {
2898 gfc_symbol* proc = gfc_current_ns->proc_name;
2899 gcc_assert (proc);
2900
2901 if (proc->result->ts.type == BT_UNKNOWN)
2902 function_result_typed = true;
2903 }
2904
2905 loop:
2906
2907 /* If we're inside a BLOCK construct, some statements are disallowed.
2908 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2909 or VALUE are also disallowed, but they don't have a particular ST_*
2910 key so we have to check for them individually in their matcher routine. */
2911 if (gfc_current_state () == COMP_BLOCK)
2912 switch (st)
2913 {
2914 case ST_IMPLICIT:
2915 case ST_IMPLICIT_NONE:
2916 case ST_NAMELIST:
2917 case ST_COMMON:
2918 case ST_EQUIVALENCE:
2919 case ST_STATEMENT_FUNCTION:
2920 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2921 gfc_ascii_statement (st));
2922 reject_statement ();
2923 break;
2924
2925 default:
2926 break;
2927 }
2928 else if (gfc_current_state () == COMP_BLOCK_DATA)
2929 /* Fortran 2008, C1116. */
2930 switch (st)
2931 {
2932 case ST_DATA_DECL:
2933 case ST_COMMON:
2934 case ST_DATA:
2935 case ST_TYPE:
2936 case ST_END_BLOCK_DATA:
2937 case ST_ATTR_DECL:
2938 case ST_EQUIVALENCE:
2939 case ST_PARAMETER:
2940 case ST_IMPLICIT:
2941 case ST_IMPLICIT_NONE:
2942 case ST_DERIVED_DECL:
2943 case ST_USE:
2944 break;
2945
2946 case ST_NONE:
2947 break;
2948
2949 default:
2950 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
2951 gfc_ascii_statement (st));
2952 reject_statement ();
2953 break;
2954 }
2955
2956 /* If we find a statement that can not be followed by an IMPLICIT statement
2957 (and thus we can expect to see none any further), type the function result
2958 if it has not yet been typed. Be careful not to give the END statement
2959 to verify_st_order! */
2960 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2961 {
2962 bool verify_now = false;
2963
2964 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2965 verify_now = true;
2966 else
2967 {
2968 st_state dummyss;
2969 verify_st_order (&dummyss, ST_NONE, false);
2970 verify_st_order (&dummyss, st, false);
2971
2972 if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
2973 verify_now = true;
2974 }
2975
2976 if (verify_now)
2977 {
2978 check_function_result_typed ();
2979 function_result_typed = true;
2980 }
2981 }
2982
2983 switch (st)
2984 {
2985 case ST_NONE:
2986 unexpected_eof ();
2987
2988 case ST_IMPLICIT_NONE:
2989 case ST_IMPLICIT:
2990 if (!function_result_typed)
2991 {
2992 check_function_result_typed ();
2993 function_result_typed = true;
2994 }
2995 goto declSt;
2996
2997 case ST_FORMAT:
2998 case ST_ENTRY:
2999 case ST_DATA: /* Not allowed in interfaces */
3000 if (gfc_current_state () == COMP_INTERFACE)
3001 break;
3002
3003 /* Fall through */
3004
3005 case ST_USE:
3006 case ST_IMPORT:
3007 case ST_PARAMETER:
3008 case ST_PUBLIC:
3009 case ST_PRIVATE:
3010 case ST_DERIVED_DECL:
3011 case_decl:
3012 declSt:
3013 if (!verify_st_order (&ss, st, false))
3014 {
3015 reject_statement ();
3016 st = next_statement ();
3017 goto loop;
3018 }
3019
3020 switch (st)
3021 {
3022 case ST_INTERFACE:
3023 parse_interface ();
3024 break;
3025
3026 case ST_DERIVED_DECL:
3027 parse_derived ();
3028 break;
3029
3030 case ST_PUBLIC:
3031 case ST_PRIVATE:
3032 if (gfc_current_state () != COMP_MODULE)
3033 {
3034 gfc_error ("%s statement must appear in a MODULE",
3035 gfc_ascii_statement (st));
3036 reject_statement ();
3037 break;
3038 }
3039
3040 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
3041 {
3042 gfc_error ("%s statement at %C follows another accessibility "
3043 "specification", gfc_ascii_statement (st));
3044 reject_statement ();
3045 break;
3046 }
3047
3048 gfc_current_ns->default_access = (st == ST_PUBLIC)
3049 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3050
3051 break;
3052
3053 case ST_STATEMENT_FUNCTION:
3054 if (gfc_current_state () == COMP_MODULE)
3055 {
3056 unexpected_statement (st);
3057 break;
3058 }
3059
3060 default:
3061 break;
3062 }
3063
3064 accept_statement (st);
3065 st = next_statement ();
3066 goto loop;
3067
3068 case ST_ENUM:
3069 accept_statement (st);
3070 parse_enum();
3071 st = next_statement ();
3072 goto loop;
3073
3074 case ST_GET_FCN_CHARACTERISTICS:
3075 /* This statement triggers the association of a function's result
3076 characteristics. */
3077 ts = &gfc_current_block ()->result->ts;
3078 if (match_deferred_characteristics (ts) != MATCH_YES)
3079 bad_characteristic = true;
3080
3081 st = next_statement ();
3082 goto loop;
3083
3084 default:
3085 break;
3086 }
3087
3088 /* If match_deferred_characteristics failed, then there is an error. */
3089 if (bad_characteristic)
3090 {
3091 ts = &gfc_current_block ()->result->ts;
3092 if (ts->type != BT_DERIVED)
3093 gfc_error ("Bad kind expression for function '%s' at %L",
3094 gfc_current_block ()->name,
3095 &gfc_current_block ()->declared_at);
3096 else
3097 gfc_error ("The type for function '%s' at %L is not accessible",
3098 gfc_current_block ()->name,
3099 &gfc_current_block ()->declared_at);
3100
3101 gfc_current_block ()->ts.kind = 0;
3102 /* Keep the derived type; if it's bad, it will be discovered later. */
3103 if (!(ts->type == BT_DERIVED && ts->u.derived))
3104 ts->type = BT_UNKNOWN;
3105 }
3106
3107 return st;
3108 }
3109
3110
3111 /* Parse a WHERE block, (not a simple WHERE statement). */
3112
3113 static void
3114 parse_where_block (void)
3115 {
3116 int seen_empty_else;
3117 gfc_code *top, *d;
3118 gfc_state_data s;
3119 gfc_statement st;
3120
3121 accept_statement (ST_WHERE_BLOCK);
3122 top = gfc_state_stack->tail;
3123
3124 push_state (&s, COMP_WHERE, gfc_new_block);
3125
3126 d = add_statement ();
3127 d->expr1 = top->expr1;
3128 d->op = EXEC_WHERE;
3129
3130 top->expr1 = NULL;
3131 top->block = d;
3132
3133 seen_empty_else = 0;
3134
3135 do
3136 {
3137 st = next_statement ();
3138 switch (st)
3139 {
3140 case ST_NONE:
3141 unexpected_eof ();
3142
3143 case ST_WHERE_BLOCK:
3144 parse_where_block ();
3145 break;
3146
3147 case ST_ASSIGNMENT:
3148 case ST_WHERE:
3149 accept_statement (st);
3150 break;
3151
3152 case ST_ELSEWHERE:
3153 if (seen_empty_else)
3154 {
3155 gfc_error ("ELSEWHERE statement at %C follows previous "
3156 "unmasked ELSEWHERE");
3157 reject_statement ();
3158 break;
3159 }
3160
3161 if (new_st.expr1 == NULL)
3162 seen_empty_else = 1;
3163
3164 d = new_level (gfc_state_stack->head);
3165 d->op = EXEC_WHERE;
3166 d->expr1 = new_st.expr1;
3167
3168 accept_statement (st);
3169
3170 break;
3171
3172 case ST_END_WHERE:
3173 accept_statement (st);
3174 break;
3175
3176 default:
3177 gfc_error ("Unexpected %s statement in WHERE block at %C",
3178 gfc_ascii_statement (st));
3179 reject_statement ();
3180 break;
3181 }
3182 }
3183 while (st != ST_END_WHERE);
3184
3185 pop_state ();
3186 }
3187
3188
3189 /* Parse a FORALL block (not a simple FORALL statement). */
3190
3191 static void
3192 parse_forall_block (void)
3193 {
3194 gfc_code *top, *d;
3195 gfc_state_data s;
3196 gfc_statement st;
3197
3198 accept_statement (ST_FORALL_BLOCK);
3199 top = gfc_state_stack->tail;
3200
3201 push_state (&s, COMP_FORALL, gfc_new_block);
3202
3203 d = add_statement ();
3204 d->op = EXEC_FORALL;
3205 top->block = d;
3206
3207 do
3208 {
3209 st = next_statement ();
3210 switch (st)
3211 {
3212
3213 case ST_ASSIGNMENT:
3214 case ST_POINTER_ASSIGNMENT:
3215 case ST_WHERE:
3216 case ST_FORALL:
3217 accept_statement (st);
3218 break;
3219
3220 case ST_WHERE_BLOCK:
3221 parse_where_block ();
3222 break;
3223
3224 case ST_FORALL_BLOCK:
3225 parse_forall_block ();
3226 break;
3227
3228 case ST_END_FORALL:
3229 accept_statement (st);
3230 break;
3231
3232 case ST_NONE:
3233 unexpected_eof ();
3234
3235 default:
3236 gfc_error ("Unexpected %s statement in FORALL block at %C",
3237 gfc_ascii_statement (st));
3238
3239 reject_statement ();
3240 break;
3241 }
3242 }
3243 while (st != ST_END_FORALL);
3244
3245 pop_state ();
3246 }
3247
3248
3249 static gfc_statement parse_executable (gfc_statement);
3250
3251 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3252
3253 static void
3254 parse_if_block (void)
3255 {
3256 gfc_code *top, *d;
3257 gfc_statement st;
3258 locus else_locus;
3259 gfc_state_data s;
3260 int seen_else;
3261
3262 seen_else = 0;
3263 accept_statement (ST_IF_BLOCK);
3264
3265 top = gfc_state_stack->tail;
3266 push_state (&s, COMP_IF, gfc_new_block);
3267
3268 new_st.op = EXEC_IF;
3269 d = add_statement ();
3270
3271 d->expr1 = top->expr1;
3272 top->expr1 = NULL;
3273 top->block = d;
3274
3275 do
3276 {
3277 st = parse_executable (ST_NONE);
3278
3279 switch (st)
3280 {
3281 case ST_NONE:
3282 unexpected_eof ();
3283
3284 case ST_ELSEIF:
3285 if (seen_else)
3286 {
3287 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3288 "statement at %L", &else_locus);
3289
3290 reject_statement ();
3291 break;
3292 }
3293
3294 d = new_level (gfc_state_stack->head);
3295 d->op = EXEC_IF;
3296 d->expr1 = new_st.expr1;
3297
3298 accept_statement (st);
3299
3300 break;
3301
3302 case ST_ELSE:
3303 if (seen_else)
3304 {
3305 gfc_error ("Duplicate ELSE statements at %L and %C",
3306 &else_locus);
3307 reject_statement ();
3308 break;
3309 }
3310
3311 seen_else = 1;
3312 else_locus = gfc_current_locus;
3313
3314 d = new_level (gfc_state_stack->head);
3315 d->op = EXEC_IF;
3316
3317 accept_statement (st);
3318
3319 break;
3320
3321 case ST_ENDIF:
3322 break;
3323
3324 default:
3325 unexpected_statement (st);
3326 break;
3327 }
3328 }
3329 while (st != ST_ENDIF);
3330
3331 pop_state ();
3332 accept_statement (st);
3333 }
3334
3335
3336 /* Parse a SELECT block. */
3337
3338 static void
3339 parse_select_block (void)
3340 {
3341 gfc_statement st;
3342 gfc_code *cp;
3343 gfc_state_data s;
3344
3345 accept_statement (ST_SELECT_CASE);
3346
3347 cp = gfc_state_stack->tail;
3348 push_state (&s, COMP_SELECT, gfc_new_block);
3349
3350 /* Make sure that the next statement is a CASE or END SELECT. */
3351 for (;;)
3352 {
3353 st = next_statement ();
3354 if (st == ST_NONE)
3355 unexpected_eof ();
3356 if (st == ST_END_SELECT)
3357 {
3358 /* Empty SELECT CASE is OK. */
3359 accept_statement (st);
3360 pop_state ();
3361 return;
3362 }
3363 if (st == ST_CASE)
3364 break;
3365
3366 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3367 "CASE at %C");
3368
3369 reject_statement ();
3370 }
3371
3372 /* At this point, we're got a nonempty select block. */
3373 cp = new_level (cp);
3374 *cp = new_st;
3375
3376 accept_statement (st);
3377
3378 do
3379 {
3380 st = parse_executable (ST_NONE);
3381 switch (st)
3382 {
3383 case ST_NONE:
3384 unexpected_eof ();
3385
3386 case ST_CASE:
3387 cp = new_level (gfc_state_stack->head);
3388 *cp = new_st;
3389 gfc_clear_new_st ();
3390
3391 accept_statement (st);
3392 /* Fall through */
3393
3394 case ST_END_SELECT:
3395 break;
3396
3397 /* Can't have an executable statement because of
3398 parse_executable(). */
3399 default:
3400 unexpected_statement (st);
3401 break;
3402 }
3403 }
3404 while (st != ST_END_SELECT);
3405
3406 pop_state ();
3407 accept_statement (st);
3408 }
3409
3410
3411 /* Pop the current selector from the SELECT TYPE stack. */
3412
3413 static void
3414 select_type_pop (void)
3415 {
3416 gfc_select_type_stack *old = select_type_stack;
3417 select_type_stack = old->prev;
3418 free (old);
3419 }
3420
3421
3422 /* Parse a SELECT TYPE construct (F03:R821). */
3423
3424 static void
3425 parse_select_type_block (void)
3426 {
3427 gfc_statement st;
3428 gfc_code *cp;
3429 gfc_state_data s;
3430
3431 accept_statement (ST_SELECT_TYPE);
3432
3433 cp = gfc_state_stack->tail;
3434 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
3435
3436 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3437 or END SELECT. */
3438 for (;;)
3439 {
3440 st = next_statement ();
3441 if (st == ST_NONE)
3442 unexpected_eof ();
3443 if (st == ST_END_SELECT)
3444 /* Empty SELECT CASE is OK. */
3445 goto done;
3446 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
3447 break;
3448
3449 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3450 "following SELECT TYPE at %C");
3451
3452 reject_statement ();
3453 }
3454
3455 /* At this point, we're got a nonempty select block. */
3456 cp = new_level (cp);
3457 *cp = new_st;
3458
3459 accept_statement (st);
3460
3461 do
3462 {
3463 st = parse_executable (ST_NONE);
3464 switch (st)
3465 {
3466 case ST_NONE:
3467 unexpected_eof ();
3468
3469 case ST_TYPE_IS:
3470 case ST_CLASS_IS:
3471 cp = new_level (gfc_state_stack->head);
3472 *cp = new_st;
3473 gfc_clear_new_st ();
3474
3475 accept_statement (st);
3476 /* Fall through */
3477
3478 case ST_END_SELECT:
3479 break;
3480
3481 /* Can't have an executable statement because of
3482 parse_executable(). */
3483 default:
3484 unexpected_statement (st);
3485 break;
3486 }
3487 }
3488 while (st != ST_END_SELECT);
3489
3490 done:
3491 pop_state ();
3492 accept_statement (st);
3493 gfc_current_ns = gfc_current_ns->parent;
3494 select_type_pop ();
3495 }
3496
3497
3498 /* Given a symbol, make sure it is not an iteration variable for a DO
3499 statement. This subroutine is called when the symbol is seen in a
3500 context that causes it to become redefined. If the symbol is an
3501 iterator, we generate an error message and return nonzero. */
3502
3503 int
3504 gfc_check_do_variable (gfc_symtree *st)
3505 {
3506 gfc_state_data *s;
3507
3508 for (s=gfc_state_stack; s; s = s->previous)
3509 if (s->do_variable == st)
3510 {
3511 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3512 "loop beginning at %L", st->name, &s->head->loc);
3513 return 1;
3514 }
3515
3516 return 0;
3517 }
3518
3519
3520 /* Checks to see if the current statement label closes an enddo.
3521 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3522 an error) if it incorrectly closes an ENDDO. */
3523
3524 static int
3525 check_do_closure (void)
3526 {
3527 gfc_state_data *p;
3528
3529 if (gfc_statement_label == NULL)
3530 return 0;
3531
3532 for (p = gfc_state_stack; p; p = p->previous)
3533 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3534 break;
3535
3536 if (p == NULL)
3537 return 0; /* No loops to close */
3538
3539 if (p->ext.end_do_label == gfc_statement_label)
3540 {
3541 if (p == gfc_state_stack)
3542 return 1;
3543
3544 gfc_error ("End of nonblock DO statement at %C is within another block");
3545 return 2;
3546 }
3547
3548 /* At this point, the label doesn't terminate the innermost loop.
3549 Make sure it doesn't terminate another one. */
3550 for (; p; p = p->previous)
3551 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3552 && p->ext.end_do_label == gfc_statement_label)
3553 {
3554 gfc_error ("End of nonblock DO statement at %C is interwoven "
3555 "with another DO loop");
3556 return 2;
3557 }
3558
3559 return 0;
3560 }
3561
3562
3563 /* Parse a series of contained program units. */
3564
3565 static void parse_progunit (gfc_statement);
3566
3567
3568 /* Parse a CRITICAL block. */
3569
3570 static void
3571 parse_critical_block (void)
3572 {
3573 gfc_code *top, *d;
3574 gfc_state_data s;
3575 gfc_statement st;
3576
3577 s.ext.end_do_label = new_st.label1;
3578
3579 accept_statement (ST_CRITICAL);
3580 top = gfc_state_stack->tail;
3581
3582 push_state (&s, COMP_CRITICAL, gfc_new_block);
3583
3584 d = add_statement ();
3585 d->op = EXEC_CRITICAL;
3586 top->block = d;
3587
3588 do
3589 {
3590 st = parse_executable (ST_NONE);
3591
3592 switch (st)
3593 {
3594 case ST_NONE:
3595 unexpected_eof ();
3596 break;
3597
3598 case ST_END_CRITICAL:
3599 if (s.ext.end_do_label != NULL
3600 && s.ext.end_do_label != gfc_statement_label)
3601 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3602 "match CRITICAL label");
3603
3604 if (gfc_statement_label != NULL)
3605 {
3606 new_st.op = EXEC_NOP;
3607 add_statement ();
3608 }
3609 break;
3610
3611 default:
3612 unexpected_statement (st);
3613 break;
3614 }
3615 }
3616 while (st != ST_END_CRITICAL);
3617
3618 pop_state ();
3619 accept_statement (st);
3620 }
3621
3622
3623 /* Set up the local namespace for a BLOCK construct. */
3624
3625 gfc_namespace*
3626 gfc_build_block_ns (gfc_namespace *parent_ns)
3627 {
3628 gfc_namespace* my_ns;
3629 static int numblock = 1;
3630
3631 my_ns = gfc_get_namespace (parent_ns, 1);
3632 my_ns->construct_entities = 1;
3633
3634 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3635 code generation (so it must not be NULL).
3636 We set its recursive argument if our container procedure is recursive, so
3637 that local variables are accordingly placed on the stack when it
3638 will be necessary. */
3639 if (gfc_new_block)
3640 my_ns->proc_name = gfc_new_block;
3641 else
3642 {
3643 bool t;
3644 char buffer[20]; /* Enough to hold "block@2147483648\n". */
3645
3646 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
3647 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
3648 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3649 my_ns->proc_name->name, NULL);
3650 gcc_assert (t);
3651 gfc_commit_symbol (my_ns->proc_name);
3652 }
3653
3654 if (parent_ns->proc_name)
3655 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3656
3657 return my_ns;
3658 }
3659
3660
3661 /* Parse a BLOCK construct. */
3662
3663 static void
3664 parse_block_construct (void)
3665 {
3666 gfc_namespace* my_ns;
3667 gfc_state_data s;
3668
3669 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
3670
3671 my_ns = gfc_build_block_ns (gfc_current_ns);
3672
3673 new_st.op = EXEC_BLOCK;
3674 new_st.ext.block.ns = my_ns;
3675 new_st.ext.block.assoc = NULL;
3676 accept_statement (ST_BLOCK);
3677
3678 push_state (&s, COMP_BLOCK, my_ns->proc_name);
3679 gfc_current_ns = my_ns;
3680
3681 parse_progunit (ST_NONE);
3682
3683 gfc_current_ns = gfc_current_ns->parent;
3684 pop_state ();
3685 }
3686
3687
3688 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3689 behind the scenes with compiler-generated variables. */
3690
3691 static void
3692 parse_associate (void)
3693 {
3694 gfc_namespace* my_ns;
3695 gfc_state_data s;
3696 gfc_statement st;
3697 gfc_association_list* a;
3698
3699 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
3700
3701 my_ns = gfc_build_block_ns (gfc_current_ns);
3702
3703 new_st.op = EXEC_BLOCK;
3704 new_st.ext.block.ns = my_ns;
3705 gcc_assert (new_st.ext.block.assoc);
3706
3707 /* Add all associate-names as BLOCK variables. Creating them is enough
3708 for now, they'll get their values during trans-* phase. */
3709 gfc_current_ns = my_ns;
3710 for (a = new_st.ext.block.assoc; a; a = a->next)
3711 {
3712 gfc_symbol* sym;
3713
3714 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3715 gcc_unreachable ();
3716
3717 sym = a->st->n.sym;
3718 sym->attr.flavor = FL_VARIABLE;
3719 sym->assoc = a;
3720 sym->declared_at = a->where;
3721 gfc_set_sym_referenced (sym);
3722
3723 /* Initialize the typespec. It is not available in all cases,
3724 however, as it may only be set on the target during resolution.
3725 Still, sometimes it helps to have it right now -- especially
3726 for parsing component references on the associate-name
3727 in case of association to a derived-type. */
3728 sym->ts = a->target->ts;
3729 }
3730
3731 accept_statement (ST_ASSOCIATE);
3732 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3733
3734 loop:
3735 st = parse_executable (ST_NONE);
3736 switch (st)
3737 {
3738 case ST_NONE:
3739 unexpected_eof ();
3740
3741 case_end:
3742 accept_statement (st);
3743 my_ns->code = gfc_state_stack->head;
3744 break;
3745
3746 default:
3747 unexpected_statement (st);
3748 goto loop;
3749 }
3750
3751 gfc_current_ns = gfc_current_ns->parent;
3752 pop_state ();
3753 }
3754
3755
3756 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3757 handled inside of parse_executable(), because they aren't really
3758 loop statements. */
3759
3760 static void
3761 parse_do_block (void)
3762 {
3763 gfc_statement st;
3764 gfc_code *top;
3765 gfc_state_data s;
3766 gfc_symtree *stree;
3767 gfc_exec_op do_op;
3768
3769 do_op = new_st.op;
3770 s.ext.end_do_label = new_st.label1;
3771
3772 if (new_st.ext.iterator != NULL)
3773 stree = new_st.ext.iterator->var->symtree;
3774 else
3775 stree = NULL;
3776
3777 accept_statement (ST_DO);
3778
3779 top = gfc_state_stack->tail;
3780 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
3781 gfc_new_block);
3782
3783 s.do_variable = stree;
3784
3785 top->block = new_level (top);
3786 top->block->op = EXEC_DO;
3787
3788 loop:
3789 st = parse_executable (ST_NONE);
3790
3791 switch (st)
3792 {
3793 case ST_NONE:
3794 unexpected_eof ();
3795
3796 case ST_ENDDO:
3797 if (s.ext.end_do_label != NULL
3798 && s.ext.end_do_label != gfc_statement_label)
3799 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3800 "DO label");
3801
3802 if (gfc_statement_label != NULL)
3803 {
3804 new_st.op = EXEC_NOP;
3805 add_statement ();
3806 }
3807 break;
3808
3809 case ST_IMPLIED_ENDDO:
3810 /* If the do-stmt of this DO construct has a do-construct-name,
3811 the corresponding end-do must be an end-do-stmt (with a matching
3812 name, but in that case we must have seen ST_ENDDO first).
3813 We only complain about this in pedantic mode. */
3814 if (gfc_current_block () != NULL)
3815 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3816 &gfc_current_block()->declared_at);
3817
3818 break;
3819
3820 default:
3821 unexpected_statement (st);
3822 goto loop;
3823 }
3824
3825 pop_state ();
3826 accept_statement (st);
3827 }
3828
3829
3830 /* Parse the statements of OpenMP do/parallel do. */
3831
3832 static gfc_statement
3833 parse_omp_do (gfc_statement omp_st)
3834 {
3835 gfc_statement st;
3836 gfc_code *cp, *np;
3837 gfc_state_data s;
3838
3839 accept_statement (omp_st);
3840
3841 cp = gfc_state_stack->tail;
3842 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3843 np = new_level (cp);
3844 np->op = cp->op;
3845 np->block = NULL;
3846
3847 for (;;)
3848 {
3849 st = next_statement ();
3850 if (st == ST_NONE)
3851 unexpected_eof ();
3852 else if (st == ST_DO)
3853 break;
3854 else
3855 unexpected_statement (st);
3856 }
3857
3858 parse_do_block ();
3859 if (gfc_statement_label != NULL
3860 && gfc_state_stack->previous != NULL
3861 && gfc_state_stack->previous->state == COMP_DO
3862 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3863 {
3864 /* In
3865 DO 100 I=1,10
3866 !$OMP DO
3867 DO J=1,10
3868 ...
3869 100 CONTINUE
3870 there should be no !$OMP END DO. */
3871 pop_state ();
3872 return ST_IMPLIED_ENDDO;
3873 }
3874
3875 check_do_closure ();
3876 pop_state ();
3877
3878 st = next_statement ();
3879 gfc_statement omp_end_st = ST_OMP_END_DO;
3880 switch (omp_st)
3881 {
3882 case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
3883 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
3884 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
3885 break;
3886 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3887 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
3888 break;
3889 case ST_OMP_DISTRIBUTE_SIMD:
3890 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
3891 break;
3892 case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
3893 case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
3894 case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
3895 case ST_OMP_PARALLEL_DO_SIMD:
3896 omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
3897 break;
3898 case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
3899 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
3900 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
3901 break;
3902 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3903 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
3904 break;
3905 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3906 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
3907 break;
3908 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3909 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
3910 break;
3911 case ST_OMP_TEAMS_DISTRIBUTE:
3912 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
3913 break;
3914 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3915 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
3916 break;
3917 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3918 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
3919 break;
3920 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
3921 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
3922 break;
3923 default: gcc_unreachable ();
3924 }
3925 if (st == omp_end_st)
3926 {
3927 if (new_st.op == EXEC_OMP_END_NOWAIT)
3928 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3929 else
3930 gcc_assert (new_st.op == EXEC_NOP);
3931 gfc_clear_new_st ();
3932 gfc_commit_symbols ();
3933 gfc_warning_check ();
3934 st = next_statement ();
3935 }
3936 return st;
3937 }
3938
3939
3940 /* Parse the statements of OpenMP atomic directive. */
3941
3942 static gfc_statement
3943 parse_omp_atomic (void)
3944 {
3945 gfc_statement st;
3946 gfc_code *cp, *np;
3947 gfc_state_data s;
3948 int count;
3949
3950 accept_statement (ST_OMP_ATOMIC);
3951
3952 cp = gfc_state_stack->tail;
3953 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3954 np = new_level (cp);
3955 np->op = cp->op;
3956 np->block = NULL;
3957 count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3958 == GFC_OMP_ATOMIC_CAPTURE);
3959
3960 while (count)
3961 {
3962 st = next_statement ();
3963 if (st == ST_NONE)
3964 unexpected_eof ();
3965 else if (st == ST_ASSIGNMENT)
3966 {
3967 accept_statement (st);
3968 count--;
3969 }
3970 else
3971 unexpected_statement (st);
3972 }
3973
3974 pop_state ();
3975
3976 st = next_statement ();
3977 if (st == ST_OMP_END_ATOMIC)
3978 {
3979 gfc_clear_new_st ();
3980 gfc_commit_symbols ();
3981 gfc_warning_check ();
3982 st = next_statement ();
3983 }
3984 else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
3985 == GFC_OMP_ATOMIC_CAPTURE)
3986 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3987 return st;
3988 }
3989
3990
3991 /* Parse the statements of an OpenMP structured block. */
3992
3993 static void
3994 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3995 {
3996 gfc_statement st, omp_end_st;
3997 gfc_code *cp, *np;
3998 gfc_state_data s;
3999
4000 accept_statement (omp_st);
4001
4002 cp = gfc_state_stack->tail;
4003 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
4004 np = new_level (cp);
4005 np->op = cp->op;
4006 np->block = NULL;
4007
4008 switch (omp_st)
4009 {
4010 case ST_OMP_PARALLEL:
4011 omp_end_st = ST_OMP_END_PARALLEL;
4012 break;
4013 case ST_OMP_PARALLEL_SECTIONS:
4014 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
4015 break;
4016 case ST_OMP_SECTIONS:
4017 omp_end_st = ST_OMP_END_SECTIONS;
4018 break;
4019 case ST_OMP_ORDERED:
4020 omp_end_st = ST_OMP_END_ORDERED;
4021 break;
4022 case ST_OMP_CRITICAL:
4023 omp_end_st = ST_OMP_END_CRITICAL;
4024 break;
4025 case ST_OMP_MASTER:
4026 omp_end_st = ST_OMP_END_MASTER;
4027 break;
4028 case ST_OMP_SINGLE:
4029 omp_end_st = ST_OMP_END_SINGLE;
4030 break;
4031 case ST_OMP_TARGET:
4032 omp_end_st = ST_OMP_END_TARGET;
4033 break;
4034 case ST_OMP_TARGET_DATA:
4035 omp_end_st = ST_OMP_END_TARGET_DATA;
4036 break;
4037 case ST_OMP_TARGET_TEAMS:
4038 omp_end_st = ST_OMP_END_TARGET_TEAMS;
4039 break;
4040 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4041 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
4042 break;
4043 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4044 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
4045 break;
4046 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4047 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4048 break;
4049 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4050 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
4051 break;
4052 case ST_OMP_TASK:
4053 omp_end_st = ST_OMP_END_TASK;
4054 break;
4055 case ST_OMP_TASKGROUP:
4056 omp_end_st = ST_OMP_END_TASKGROUP;
4057 break;
4058 case ST_OMP_TEAMS:
4059 omp_end_st = ST_OMP_END_TEAMS;
4060 break;
4061 case ST_OMP_TEAMS_DISTRIBUTE:
4062 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
4063 break;
4064 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4065 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
4066 break;
4067 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4068 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4069 break;
4070 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
4071 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
4072 break;
4073 case ST_OMP_DISTRIBUTE:
4074 omp_end_st = ST_OMP_END_DISTRIBUTE;
4075 break;
4076 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4077 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
4078 break;
4079 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4080 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
4081 break;
4082 case ST_OMP_DISTRIBUTE_SIMD:
4083 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
4084 break;
4085 case ST_OMP_WORKSHARE:
4086 omp_end_st = ST_OMP_END_WORKSHARE;
4087 break;
4088 case ST_OMP_PARALLEL_WORKSHARE:
4089 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
4090 break;
4091 default:
4092 gcc_unreachable ();
4093 }
4094
4095 do
4096 {
4097 if (workshare_stmts_only)
4098 {
4099 /* Inside of !$omp workshare, only
4100 scalar assignments
4101 array assignments
4102 where statements and constructs
4103 forall statements and constructs
4104 !$omp atomic
4105 !$omp critical
4106 !$omp parallel
4107 are allowed. For !$omp critical these
4108 restrictions apply recursively. */
4109 bool cycle = true;
4110
4111 st = next_statement ();
4112 for (;;)
4113 {
4114 switch (st)
4115 {
4116 case ST_NONE:
4117 unexpected_eof ();
4118
4119 case ST_ASSIGNMENT:
4120 case ST_WHERE:
4121 case ST_FORALL:
4122 accept_statement (st);
4123 break;
4124
4125 case ST_WHERE_BLOCK:
4126 parse_where_block ();
4127 break;
4128
4129 case ST_FORALL_BLOCK:
4130 parse_forall_block ();
4131 break;
4132
4133 case ST_OMP_PARALLEL:
4134 case ST_OMP_PARALLEL_SECTIONS:
4135 parse_omp_structured_block (st, false);
4136 break;
4137
4138 case ST_OMP_PARALLEL_WORKSHARE:
4139 case ST_OMP_CRITICAL:
4140 parse_omp_structured_block (st, true);
4141 break;
4142
4143 case ST_OMP_PARALLEL_DO:
4144 case ST_OMP_PARALLEL_DO_SIMD:
4145 st = parse_omp_do (st);
4146 continue;
4147
4148 case ST_OMP_ATOMIC:
4149 st = parse_omp_atomic ();
4150 continue;
4151
4152 default:
4153 cycle = false;
4154 break;
4155 }
4156
4157 if (!cycle)
4158 break;
4159
4160 st = next_statement ();
4161 }
4162 }
4163 else
4164 st = parse_executable (ST_NONE);
4165 if (st == ST_NONE)
4166 unexpected_eof ();
4167 else if (st == ST_OMP_SECTION
4168 && (omp_st == ST_OMP_SECTIONS
4169 || omp_st == ST_OMP_PARALLEL_SECTIONS))
4170 {
4171 np = new_level (np);
4172 np->op = cp->op;
4173 np->block = NULL;
4174 }
4175 else if (st != omp_end_st)
4176 unexpected_statement (st);
4177 }
4178 while (st != omp_end_st);
4179
4180 switch (new_st.op)
4181 {
4182 case EXEC_OMP_END_NOWAIT:
4183 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
4184 break;
4185 case EXEC_OMP_CRITICAL:
4186 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
4187 || (new_st.ext.omp_name != NULL
4188 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
4189 gfc_error ("Name after !$omp critical and !$omp end critical does "
4190 "not match at %C");
4191 free (CONST_CAST (char *, new_st.ext.omp_name));
4192 break;
4193 case EXEC_OMP_END_SINGLE:
4194 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
4195 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
4196 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
4197 gfc_free_omp_clauses (new_st.ext.omp_clauses);
4198 break;
4199 case EXEC_NOP:
4200 break;
4201 default:
4202 gcc_unreachable ();
4203 }
4204
4205 gfc_clear_new_st ();
4206 gfc_commit_symbols ();
4207 gfc_warning_check ();
4208 pop_state ();
4209 }
4210
4211
4212 /* Accept a series of executable statements. We return the first
4213 statement that doesn't fit to the caller. Any block statements are
4214 passed on to the correct handler, which usually passes the buck
4215 right back here. */
4216
4217 static gfc_statement
4218 parse_executable (gfc_statement st)
4219 {
4220 int close_flag;
4221
4222 if (st == ST_NONE)
4223 st = next_statement ();
4224
4225 for (;;)
4226 {
4227 close_flag = check_do_closure ();
4228 if (close_flag)
4229 switch (st)
4230 {
4231 case ST_GOTO:
4232 case ST_END_PROGRAM:
4233 case ST_RETURN:
4234 case ST_EXIT:
4235 case ST_END_FUNCTION:
4236 case ST_CYCLE:
4237 case ST_PAUSE:
4238 case ST_STOP:
4239 case ST_ERROR_STOP:
4240 case ST_END_SUBROUTINE:
4241
4242 case ST_DO:
4243 case ST_FORALL:
4244 case ST_WHERE:
4245 case ST_SELECT_CASE:
4246 gfc_error ("%s statement at %C cannot terminate a non-block "
4247 "DO loop", gfc_ascii_statement (st));
4248 break;
4249
4250 default:
4251 break;
4252 }
4253
4254 switch (st)
4255 {
4256 case ST_NONE:
4257 unexpected_eof ();
4258
4259 case ST_DATA:
4260 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
4261 "first executable statement");
4262 /* Fall through. */
4263
4264 case ST_FORMAT:
4265 case ST_ENTRY:
4266 case_executable:
4267 accept_statement (st);
4268 if (close_flag == 1)
4269 return ST_IMPLIED_ENDDO;
4270 break;
4271
4272 case ST_BLOCK:
4273 parse_block_construct ();
4274 break;
4275
4276 case ST_ASSOCIATE:
4277 parse_associate ();
4278 break;
4279
4280 case ST_IF_BLOCK:
4281 parse_if_block ();
4282 break;
4283
4284 case ST_SELECT_CASE:
4285 parse_select_block ();
4286 break;
4287
4288 case ST_SELECT_TYPE:
4289 parse_select_type_block();
4290 break;
4291
4292 case ST_DO:
4293 parse_do_block ();
4294 if (check_do_closure () == 1)
4295 return ST_IMPLIED_ENDDO;
4296 break;
4297
4298 case ST_CRITICAL:
4299 parse_critical_block ();
4300 break;
4301
4302 case ST_WHERE_BLOCK:
4303 parse_where_block ();
4304 break;
4305
4306 case ST_FORALL_BLOCK:
4307 parse_forall_block ();
4308 break;
4309
4310 case ST_OMP_PARALLEL:
4311 case ST_OMP_PARALLEL_SECTIONS:
4312 case ST_OMP_SECTIONS:
4313 case ST_OMP_ORDERED:
4314 case ST_OMP_CRITICAL:
4315 case ST_OMP_MASTER:
4316 case ST_OMP_SINGLE:
4317 case ST_OMP_TARGET:
4318 case ST_OMP_TARGET_DATA:
4319 case ST_OMP_TARGET_TEAMS:
4320 case ST_OMP_TEAMS:
4321 case ST_OMP_TASK:
4322 case ST_OMP_TASKGROUP:
4323 parse_omp_structured_block (st, false);
4324 break;
4325
4326 case ST_OMP_WORKSHARE:
4327 case ST_OMP_PARALLEL_WORKSHARE:
4328 parse_omp_structured_block (st, true);
4329 break;
4330
4331 case ST_OMP_DISTRIBUTE:
4332 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4333 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4334 case ST_OMP_DISTRIBUTE_SIMD:
4335 case ST_OMP_DO:
4336 case ST_OMP_DO_SIMD:
4337 case ST_OMP_PARALLEL_DO:
4338 case ST_OMP_PARALLEL_DO_SIMD:
4339 case ST_OMP_SIMD:
4340 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4341 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4342 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4343 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4344 case ST_OMP_TEAMS_DISTRIBUTE:
4345 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4346 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4347 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
4348 st = parse_omp_do (st);
4349 if (st == ST_IMPLIED_ENDDO)
4350 return st;
4351 continue;
4352
4353 case ST_OMP_ATOMIC:
4354 st = parse_omp_atomic ();
4355 continue;
4356
4357 default:
4358 return st;
4359 }
4360
4361 st = next_statement ();
4362 }
4363 }
4364
4365
4366 /* Fix the symbols for sibling functions. These are incorrectly added to
4367 the child namespace as the parser didn't know about this procedure. */
4368
4369 static void
4370 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
4371 {
4372 gfc_namespace *ns;
4373 gfc_symtree *st;
4374 gfc_symbol *old_sym;
4375
4376 for (ns = siblings; ns; ns = ns->sibling)
4377 {
4378 st = gfc_find_symtree (ns->sym_root, sym->name);
4379
4380 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
4381 goto fixup_contained;
4382
4383 if ((st->n.sym->attr.flavor == FL_DERIVED
4384 && sym->attr.generic && sym->attr.function)
4385 ||(sym->attr.flavor == FL_DERIVED
4386 && st->n.sym->attr.generic && st->n.sym->attr.function))
4387 goto fixup_contained;
4388
4389 old_sym = st->n.sym;
4390 if (old_sym->ns == ns
4391 && !old_sym->attr.contained
4392
4393 /* By 14.6.1.3, host association should be excluded
4394 for the following. */
4395 && !(old_sym->attr.external
4396 || (old_sym->ts.type != BT_UNKNOWN
4397 && !old_sym->attr.implicit_type)
4398 || old_sym->attr.flavor == FL_PARAMETER
4399 || old_sym->attr.use_assoc
4400 || old_sym->attr.in_common
4401 || old_sym->attr.in_equivalence
4402 || old_sym->attr.data
4403 || old_sym->attr.dummy
4404 || old_sym->attr.result
4405 || old_sym->attr.dimension
4406 || old_sym->attr.allocatable
4407 || old_sym->attr.intrinsic
4408 || old_sym->attr.generic
4409 || old_sym->attr.flavor == FL_NAMELIST
4410 || old_sym->attr.flavor == FL_LABEL
4411 || old_sym->attr.proc == PROC_ST_FUNCTION))
4412 {
4413 /* Replace it with the symbol from the parent namespace. */
4414 st->n.sym = sym;
4415 sym->refs++;
4416
4417 gfc_release_symbol (old_sym);
4418 }
4419
4420 fixup_contained:
4421 /* Do the same for any contained procedures. */
4422 gfc_fixup_sibling_symbols (sym, ns->contained);
4423 }
4424 }
4425
4426 static void
4427 parse_contained (int module)
4428 {
4429 gfc_namespace *ns, *parent_ns, *tmp;
4430 gfc_state_data s1, s2;
4431 gfc_statement st;
4432 gfc_symbol *sym;
4433 gfc_entry_list *el;
4434 int contains_statements = 0;
4435 int seen_error = 0;
4436
4437 push_state (&s1, COMP_CONTAINS, NULL);
4438 parent_ns = gfc_current_ns;
4439
4440 do
4441 {
4442 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
4443
4444 gfc_current_ns->sibling = parent_ns->contained;
4445 parent_ns->contained = gfc_current_ns;
4446
4447 next:
4448 /* Process the next available statement. We come here if we got an error
4449 and rejected the last statement. */
4450 st = next_statement ();
4451
4452 switch (st)
4453 {
4454 case ST_NONE:
4455 unexpected_eof ();
4456
4457 case ST_FUNCTION:
4458 case ST_SUBROUTINE:
4459 contains_statements = 1;
4460 accept_statement (st);
4461
4462 push_state (&s2,
4463 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
4464 gfc_new_block);
4465
4466 /* For internal procedures, create/update the symbol in the
4467 parent namespace. */
4468
4469 if (!module)
4470 {
4471 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
4472 gfc_error ("Contained procedure '%s' at %C is already "
4473 "ambiguous", gfc_new_block->name);
4474 else
4475 {
4476 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
4477 sym->name,
4478 &gfc_new_block->declared_at))
4479 {
4480 if (st == ST_FUNCTION)
4481 gfc_add_function (&sym->attr, sym->name,
4482 &gfc_new_block->declared_at);
4483 else
4484 gfc_add_subroutine (&sym->attr, sym->name,
4485 &gfc_new_block->declared_at);
4486 }
4487 }
4488
4489 gfc_commit_symbols ();
4490 }
4491 else
4492 sym = gfc_new_block;
4493
4494 /* Mark this as a contained function, so it isn't replaced
4495 by other module functions. */
4496 sym->attr.contained = 1;
4497
4498 /* Set implicit_pure so that it can be reset if any of the
4499 tests for purity fail. This is used for some optimisation
4500 during translation. */
4501 if (!sym->attr.pure)
4502 sym->attr.implicit_pure = 1;
4503
4504 parse_progunit (ST_NONE);
4505
4506 /* Fix up any sibling functions that refer to this one. */
4507 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
4508 /* Or refer to any of its alternate entry points. */
4509 for (el = gfc_current_ns->entries; el; el = el->next)
4510 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
4511
4512 gfc_current_ns->code = s2.head;
4513 gfc_current_ns = parent_ns;
4514
4515 pop_state ();
4516 break;
4517
4518 /* These statements are associated with the end of the host unit. */
4519 case ST_END_FUNCTION:
4520 case ST_END_MODULE:
4521 case ST_END_PROGRAM:
4522 case ST_END_SUBROUTINE:
4523 accept_statement (st);
4524 gfc_current_ns->code = s1.head;
4525 break;
4526
4527 default:
4528 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4529 gfc_ascii_statement (st));
4530 reject_statement ();
4531 seen_error = 1;
4532 goto next;
4533 break;
4534 }
4535 }
4536 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
4537 && st != ST_END_MODULE && st != ST_END_PROGRAM);
4538
4539 /* The first namespace in the list is guaranteed to not have
4540 anything (worthwhile) in it. */
4541 tmp = gfc_current_ns;
4542 gfc_current_ns = parent_ns;
4543 if (seen_error && tmp->refs > 1)
4544 gfc_free_namespace (tmp);
4545
4546 ns = gfc_current_ns->contained;
4547 gfc_current_ns->contained = ns->sibling;
4548 gfc_free_namespace (ns);
4549
4550 pop_state ();
4551 if (!contains_statements)
4552 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
4553 "FUNCTION or SUBROUTINE statement at %C");
4554 }
4555
4556
4557 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4558
4559 static void
4560 parse_progunit (gfc_statement st)
4561 {
4562 gfc_state_data *p;
4563 int n;
4564
4565 st = parse_spec (st);
4566 switch (st)
4567 {
4568 case ST_NONE:
4569 unexpected_eof ();
4570
4571 case ST_CONTAINS:
4572 /* This is not allowed within BLOCK! */
4573 if (gfc_current_state () != COMP_BLOCK)
4574 goto contains;
4575 break;
4576
4577 case_end:
4578 accept_statement (st);
4579 goto done;
4580
4581 default:
4582 break;
4583 }
4584
4585 if (gfc_current_state () == COMP_FUNCTION)
4586 gfc_check_function_type (gfc_current_ns);
4587
4588 loop:
4589 for (;;)
4590 {
4591 st = parse_executable (st);
4592
4593 switch (st)
4594 {
4595 case ST_NONE:
4596 unexpected_eof ();
4597
4598 case ST_CONTAINS:
4599 /* This is not allowed within BLOCK! */
4600 if (gfc_current_state () != COMP_BLOCK)
4601 goto contains;
4602 break;
4603
4604 case_end:
4605 accept_statement (st);
4606 goto done;
4607
4608 default:
4609 break;
4610 }
4611
4612 unexpected_statement (st);
4613 reject_statement ();
4614 st = next_statement ();
4615 }
4616
4617 contains:
4618 n = 0;
4619
4620 for (p = gfc_state_stack; p; p = p->previous)
4621 if (p->state == COMP_CONTAINS)
4622 n++;
4623
4624 if (gfc_find_state (COMP_MODULE) == true)
4625 n--;
4626
4627 if (n > 0)
4628 {
4629 gfc_error ("CONTAINS statement at %C is already in a contained "
4630 "program unit");
4631 reject_statement ();
4632 st = next_statement ();
4633 goto loop;
4634 }
4635
4636 parse_contained (0);
4637
4638 done:
4639 gfc_current_ns->code = gfc_state_stack->head;
4640 }
4641
4642
4643 /* Come here to complain about a global symbol already in use as
4644 something else. */
4645
4646 void
4647 gfc_global_used (gfc_gsymbol *sym, locus *where)
4648 {
4649 const char *name;
4650
4651 if (where == NULL)
4652 where = &gfc_current_locus;
4653
4654 switch(sym->type)
4655 {
4656 case GSYM_PROGRAM:
4657 name = "PROGRAM";
4658 break;
4659 case GSYM_FUNCTION:
4660 name = "FUNCTION";
4661 break;
4662 case GSYM_SUBROUTINE:
4663 name = "SUBROUTINE";
4664 break;
4665 case GSYM_COMMON:
4666 name = "COMMON";
4667 break;
4668 case GSYM_BLOCK_DATA:
4669 name = "BLOCK DATA";
4670 break;
4671 case GSYM_MODULE:
4672 name = "MODULE";
4673 break;
4674 default:
4675 gfc_internal_error ("gfc_global_used(): Bad type");
4676 name = NULL;
4677 }
4678
4679 if (sym->binding_label)
4680 gfc_error ("Global binding name '%s' at %L is already being used as a %s "
4681 "at %L", sym->binding_label, where, name, &sym->where);
4682 else
4683 gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
4684 sym->name, where, name, &sym->where);
4685 }
4686
4687
4688 /* Parse a block data program unit. */
4689
4690 static void
4691 parse_block_data (void)
4692 {
4693 gfc_statement st;
4694 static locus blank_locus;
4695 static int blank_block=0;
4696 gfc_gsymbol *s;
4697
4698 gfc_current_ns->proc_name = gfc_new_block;
4699 gfc_current_ns->is_block_data = 1;
4700
4701 if (gfc_new_block == NULL)
4702 {
4703 if (blank_block)
4704 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4705 "prior BLOCK DATA at %L", &blank_locus);
4706 else
4707 {
4708 blank_block = 1;
4709 blank_locus = gfc_current_locus;
4710 }
4711 }
4712 else
4713 {
4714 s = gfc_get_gsymbol (gfc_new_block->name);
4715 if (s->defined
4716 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4717 gfc_global_used (s, &gfc_new_block->declared_at);
4718 else
4719 {
4720 s->type = GSYM_BLOCK_DATA;
4721 s->where = gfc_new_block->declared_at;
4722 s->defined = 1;
4723 }
4724 }
4725
4726 st = parse_spec (ST_NONE);
4727
4728 while (st != ST_END_BLOCK_DATA)
4729 {
4730 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4731 gfc_ascii_statement (st));
4732 reject_statement ();
4733 st = next_statement ();
4734 }
4735 }
4736
4737
4738 /* Parse a module subprogram. */
4739
4740 static void
4741 parse_module (void)
4742 {
4743 gfc_statement st;
4744 gfc_gsymbol *s;
4745 bool error;
4746
4747 s = gfc_get_gsymbol (gfc_new_block->name);
4748 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4749 gfc_global_used (s, &gfc_new_block->declared_at);
4750 else
4751 {
4752 s->type = GSYM_MODULE;
4753 s->where = gfc_new_block->declared_at;
4754 s->defined = 1;
4755 }
4756
4757 st = parse_spec (ST_NONE);
4758
4759 error = false;
4760 loop:
4761 switch (st)
4762 {
4763 case ST_NONE:
4764 unexpected_eof ();
4765
4766 case ST_CONTAINS:
4767 parse_contained (1);
4768 break;
4769
4770 case ST_END_MODULE:
4771 accept_statement (st);
4772 break;
4773
4774 default:
4775 gfc_error ("Unexpected %s statement in MODULE at %C",
4776 gfc_ascii_statement (st));
4777
4778 error = true;
4779 reject_statement ();
4780 st = next_statement ();
4781 goto loop;
4782 }
4783
4784 /* Make sure not to free the namespace twice on error. */
4785 if (!error)
4786 s->ns = gfc_current_ns;
4787 }
4788
4789
4790 /* Add a procedure name to the global symbol table. */
4791
4792 static void
4793 add_global_procedure (bool sub)
4794 {
4795 gfc_gsymbol *s;
4796
4797 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
4798 name is a global identifier. */
4799 if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
4800 {
4801 s = gfc_get_gsymbol (gfc_new_block->name);
4802
4803 if (s->defined
4804 || (s->type != GSYM_UNKNOWN
4805 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4806 {
4807 gfc_global_used (s, &gfc_new_block->declared_at);
4808 /* Silence follow-up errors. */
4809 gfc_new_block->binding_label = NULL;
4810 }
4811 else
4812 {
4813 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4814 s->sym_name = gfc_new_block->name;
4815 s->where = gfc_new_block->declared_at;
4816 s->defined = 1;
4817 s->ns = gfc_current_ns;
4818 }
4819 }
4820
4821 /* Don't add the symbol multiple times. */
4822 if (gfc_new_block->binding_label
4823 && (!gfc_notification_std (GFC_STD_F2008)
4824 || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
4825 {
4826 s = gfc_get_gsymbol (gfc_new_block->binding_label);
4827
4828 if (s->defined
4829 || (s->type != GSYM_UNKNOWN
4830 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4831 {
4832 gfc_global_used (s, &gfc_new_block->declared_at);
4833 /* Silence follow-up errors. */
4834 gfc_new_block->binding_label = NULL;
4835 }
4836 else
4837 {
4838 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4839 s->sym_name = gfc_new_block->name;
4840 s->binding_label = gfc_new_block->binding_label;
4841 s->where = gfc_new_block->declared_at;
4842 s->defined = 1;
4843 s->ns = gfc_current_ns;
4844 }
4845 }
4846 }
4847
4848
4849 /* Add a program to the global symbol table. */
4850
4851 static void
4852 add_global_program (void)
4853 {
4854 gfc_gsymbol *s;
4855
4856 if (gfc_new_block == NULL)
4857 return;
4858 s = gfc_get_gsymbol (gfc_new_block->name);
4859
4860 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4861 gfc_global_used (s, &gfc_new_block->declared_at);
4862 else
4863 {
4864 s->type = GSYM_PROGRAM;
4865 s->where = gfc_new_block->declared_at;
4866 s->defined = 1;
4867 s->ns = gfc_current_ns;
4868 }
4869 }
4870
4871
4872 /* Resolve all the program units. */
4873 static void
4874 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4875 {
4876 gfc_free_dt_list ();
4877 gfc_current_ns = gfc_global_ns_list;
4878 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4879 {
4880 if (gfc_current_ns->proc_name
4881 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4882 continue; /* Already resolved. */
4883
4884 if (gfc_current_ns->proc_name)
4885 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4886 gfc_resolve (gfc_current_ns);
4887 gfc_current_ns->derived_types = gfc_derived_types;
4888 gfc_derived_types = NULL;
4889 }
4890 }
4891
4892
4893 static void
4894 clean_up_modules (gfc_gsymbol *gsym)
4895 {
4896 if (gsym == NULL)
4897 return;
4898
4899 clean_up_modules (gsym->left);
4900 clean_up_modules (gsym->right);
4901
4902 if (gsym->type != GSYM_MODULE || !gsym->ns)
4903 return;
4904
4905 gfc_current_ns = gsym->ns;
4906 gfc_derived_types = gfc_current_ns->derived_types;
4907 gfc_done_2 ();
4908 gsym->ns = NULL;
4909 return;
4910 }
4911
4912
4913 /* Translate all the program units. This could be in a different order
4914 to resolution if there are forward references in the file. */
4915 static void
4916 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4917 {
4918 int errors;
4919
4920 gfc_current_ns = gfc_global_ns_list;
4921 gfc_get_errors (NULL, &errors);
4922
4923 /* We first translate all modules to make sure that later parts
4924 of the program can use the decl. Then we translate the nonmodules. */
4925
4926 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4927 {
4928 if (!gfc_current_ns->proc_name
4929 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4930 continue;
4931
4932 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4933 gfc_derived_types = gfc_current_ns->derived_types;
4934 gfc_generate_module_code (gfc_current_ns);
4935 gfc_current_ns->translated = 1;
4936 }
4937
4938 gfc_current_ns = gfc_global_ns_list;
4939 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4940 {
4941 if (gfc_current_ns->proc_name
4942 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4943 continue;
4944
4945 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4946 gfc_derived_types = gfc_current_ns->derived_types;
4947 gfc_generate_code (gfc_current_ns);
4948 gfc_current_ns->translated = 1;
4949 }
4950
4951 /* Clean up all the namespaces after translation. */
4952 gfc_current_ns = gfc_global_ns_list;
4953 for (;gfc_current_ns;)
4954 {
4955 gfc_namespace *ns;
4956
4957 if (gfc_current_ns->proc_name
4958 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4959 {
4960 gfc_current_ns = gfc_current_ns->sibling;
4961 continue;
4962 }
4963
4964 ns = gfc_current_ns->sibling;
4965 gfc_derived_types = gfc_current_ns->derived_types;
4966 gfc_done_2 ();
4967 gfc_current_ns = ns;
4968 }
4969
4970 clean_up_modules (gfc_gsym_root);
4971 }
4972
4973
4974 /* Top level parser. */
4975
4976 bool
4977 gfc_parse_file (void)
4978 {
4979 int seen_program, errors_before, errors;
4980 gfc_state_data top, s;
4981 gfc_statement st;
4982 locus prog_locus;
4983 gfc_namespace *next;
4984
4985 gfc_start_source_files ();
4986
4987 top.state = COMP_NONE;
4988 top.sym = NULL;
4989 top.previous = NULL;
4990 top.head = top.tail = NULL;
4991 top.do_variable = NULL;
4992
4993 gfc_state_stack = &top;
4994
4995 gfc_clear_new_st ();
4996
4997 gfc_statement_label = NULL;
4998
4999 if (setjmp (eof_buf))
5000 return false; /* Come here on unexpected EOF */
5001
5002 /* Prepare the global namespace that will contain the
5003 program units. */
5004 gfc_global_ns_list = next = NULL;
5005
5006 seen_program = 0;
5007 errors_before = 0;
5008
5009 /* Exit early for empty files. */
5010 if (gfc_at_eof ())
5011 goto done;
5012
5013 loop:
5014 gfc_init_2 ();
5015 st = next_statement ();
5016 switch (st)
5017 {
5018 case ST_NONE:
5019 gfc_done_2 ();
5020 goto done;
5021
5022 case ST_PROGRAM:
5023 if (seen_program)
5024 goto duplicate_main;
5025 seen_program = 1;
5026 prog_locus = gfc_current_locus;
5027
5028 push_state (&s, COMP_PROGRAM, gfc_new_block);
5029 main_program_symbol(gfc_current_ns, gfc_new_block->name);
5030 accept_statement (st);
5031 add_global_program ();
5032 parse_progunit (ST_NONE);
5033 goto prog_units;
5034 break;
5035
5036 case ST_SUBROUTINE:
5037 add_global_procedure (true);
5038 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
5039 accept_statement (st);
5040 parse_progunit (ST_NONE);
5041 goto prog_units;
5042 break;
5043
5044 case ST_FUNCTION:
5045 add_global_procedure (false);
5046 push_state (&s, COMP_FUNCTION, gfc_new_block);
5047 accept_statement (st);
5048 parse_progunit (ST_NONE);
5049 goto prog_units;
5050 break;
5051
5052 case ST_BLOCK_DATA:
5053 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
5054 accept_statement (st);
5055 parse_block_data ();
5056 break;
5057
5058 case ST_MODULE:
5059 push_state (&s, COMP_MODULE, gfc_new_block);
5060 accept_statement (st);
5061
5062 gfc_get_errors (NULL, &errors_before);
5063 parse_module ();
5064 break;
5065
5066 /* Anything else starts a nameless main program block. */
5067 default:
5068 if (seen_program)
5069 goto duplicate_main;
5070 seen_program = 1;
5071 prog_locus = gfc_current_locus;
5072
5073 push_state (&s, COMP_PROGRAM, gfc_new_block);
5074 main_program_symbol (gfc_current_ns, "MAIN__");
5075 parse_progunit (st);
5076 goto prog_units;
5077 break;
5078 }
5079
5080 /* Handle the non-program units. */
5081 gfc_current_ns->code = s.head;
5082
5083 gfc_resolve (gfc_current_ns);
5084
5085 /* Dump the parse tree if requested. */
5086 if (gfc_option.dump_fortran_original)
5087 gfc_dump_parse_tree (gfc_current_ns, stdout);
5088
5089 gfc_get_errors (NULL, &errors);
5090 if (s.state == COMP_MODULE)
5091 {
5092 gfc_dump_module (s.sym->name, errors_before == errors);
5093 gfc_current_ns->derived_types = gfc_derived_types;
5094 gfc_derived_types = NULL;
5095 goto prog_units;
5096 }
5097 else
5098 {
5099 if (errors == 0)
5100 gfc_generate_code (gfc_current_ns);
5101 pop_state ();
5102 gfc_done_2 ();
5103 }
5104
5105 goto loop;
5106
5107 prog_units:
5108 /* The main program and non-contained procedures are put
5109 in the global namespace list, so that they can be processed
5110 later and all their interfaces resolved. */
5111 gfc_current_ns->code = s.head;
5112 if (next)
5113 {
5114 for (; next->sibling; next = next->sibling)
5115 ;
5116 next->sibling = gfc_current_ns;
5117 }
5118 else
5119 gfc_global_ns_list = gfc_current_ns;
5120
5121 next = gfc_current_ns;
5122
5123 pop_state ();
5124 goto loop;
5125
5126 done:
5127
5128 /* Do the resolution. */
5129 resolve_all_program_units (gfc_global_ns_list);
5130
5131 /* Do the parse tree dump. */
5132 gfc_current_ns
5133 = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
5134
5135 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
5136 if (!gfc_current_ns->proc_name
5137 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5138 {
5139 gfc_dump_parse_tree (gfc_current_ns, stdout);
5140 fputs ("------------------------------------------\n\n", stdout);
5141 }
5142
5143 /* Do the translation. */
5144 translate_all_program_units (gfc_global_ns_list);
5145
5146 gfc_end_source_files ();
5147 return true;
5148
5149 duplicate_main:
5150 /* If we see a duplicate main program, shut down. If the second
5151 instance is an implied main program, i.e. data decls or executable
5152 statements, we're in for lots of errors. */
5153 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
5154 reject_statement ();
5155 gfc_done_2 ();
5156 return true;
5157 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org