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