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