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 if (!st)
4444 return 0;
4445
4446 for (s=gfc_state_stack; s; s = s->previous)
4447 if (s->do_variable == st)
4448 {
4449 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4450 "loop beginning at %L", st->name, &s->head->loc);
4451 return 1;
4452 }
4453
4454 return 0;
4455 }
4456
4457
4458 /* Checks to see if the current statement label closes an enddo.
4459 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4460 an error) if it incorrectly closes an ENDDO. */
4461
4462 static int
check_do_closure(void)4463 check_do_closure (void)
4464 {
4465 gfc_state_data *p;
4466
4467 if (gfc_statement_label == NULL)
4468 return 0;
4469
4470 for (p = gfc_state_stack; p; p = p->previous)
4471 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4472 break;
4473
4474 if (p == NULL)
4475 return 0; /* No loops to close */
4476
4477 if (p->ext.end_do_label == gfc_statement_label)
4478 {
4479 if (p == gfc_state_stack)
4480 return 1;
4481
4482 gfc_error ("End of nonblock DO statement at %C is within another block");
4483 return 2;
4484 }
4485
4486 /* At this point, the label doesn't terminate the innermost loop.
4487 Make sure it doesn't terminate another one. */
4488 for (; p; p = p->previous)
4489 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4490 && p->ext.end_do_label == gfc_statement_label)
4491 {
4492 gfc_error ("End of nonblock DO statement at %C is interwoven "
4493 "with another DO loop");
4494 return 2;
4495 }
4496
4497 return 0;
4498 }
4499
4500
4501 /* Parse a series of contained program units. */
4502
4503 static void parse_progunit (gfc_statement);
4504
4505
4506 /* Parse a CRITICAL block. */
4507
4508 static void
parse_critical_block(void)4509 parse_critical_block (void)
4510 {
4511 gfc_code *top, *d;
4512 gfc_state_data s, *sd;
4513 gfc_statement st;
4514
4515 for (sd = gfc_state_stack; sd; sd = sd->previous)
4516 if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
4517 gfc_error_now (is_oacc (sd)
4518 ? G_("CRITICAL block inside of OpenACC region at %C")
4519 : G_("CRITICAL block inside of OpenMP region at %C"));
4520
4521 s.ext.end_do_label = new_st.label1;
4522
4523 accept_statement (ST_CRITICAL);
4524 top = gfc_state_stack->tail;
4525
4526 push_state (&s, COMP_CRITICAL, gfc_new_block);
4527
4528 d = add_statement ();
4529 d->op = EXEC_CRITICAL;
4530 top->block = d;
4531
4532 do
4533 {
4534 st = parse_executable (ST_NONE);
4535
4536 switch (st)
4537 {
4538 case ST_NONE:
4539 unexpected_eof ();
4540 break;
4541
4542 case ST_END_CRITICAL:
4543 if (s.ext.end_do_label != NULL
4544 && s.ext.end_do_label != gfc_statement_label)
4545 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4546 "match CRITICAL label");
4547
4548 if (gfc_statement_label != NULL)
4549 {
4550 new_st.op = EXEC_NOP;
4551 add_statement ();
4552 }
4553 break;
4554
4555 default:
4556 unexpected_statement (st);
4557 break;
4558 }
4559 }
4560 while (st != ST_END_CRITICAL);
4561
4562 pop_state ();
4563 accept_statement (st);
4564 }
4565
4566
4567 /* Set up the local namespace for a BLOCK construct. */
4568
4569 gfc_namespace*
gfc_build_block_ns(gfc_namespace * parent_ns)4570 gfc_build_block_ns (gfc_namespace *parent_ns)
4571 {
4572 gfc_namespace* my_ns;
4573 static int numblock = 1;
4574
4575 my_ns = gfc_get_namespace (parent_ns, 1);
4576 my_ns->construct_entities = 1;
4577
4578 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4579 code generation (so it must not be NULL).
4580 We set its recursive argument if our container procedure is recursive, so
4581 that local variables are accordingly placed on the stack when it
4582 will be necessary. */
4583 if (gfc_new_block)
4584 my_ns->proc_name = gfc_new_block;
4585 else
4586 {
4587 bool t;
4588 char buffer[20]; /* Enough to hold "block@2147483648\n". */
4589
4590 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
4591 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
4592 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
4593 my_ns->proc_name->name, NULL);
4594 gcc_assert (t);
4595 gfc_commit_symbol (my_ns->proc_name);
4596 }
4597
4598 if (parent_ns->proc_name)
4599 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
4600
4601 return my_ns;
4602 }
4603
4604
4605 /* Parse a BLOCK construct. */
4606
4607 static void
parse_block_construct(void)4608 parse_block_construct (void)
4609 {
4610 gfc_namespace* my_ns;
4611 gfc_namespace* my_parent;
4612 gfc_state_data s;
4613
4614 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
4615
4616 my_ns = gfc_build_block_ns (gfc_current_ns);
4617
4618 new_st.op = EXEC_BLOCK;
4619 new_st.ext.block.ns = my_ns;
4620 new_st.ext.block.assoc = NULL;
4621 accept_statement (ST_BLOCK);
4622
4623 push_state (&s, COMP_BLOCK, my_ns->proc_name);
4624 gfc_current_ns = my_ns;
4625 my_parent = my_ns->parent;
4626
4627 parse_progunit (ST_NONE);
4628
4629 /* Don't depend on the value of gfc_current_ns; it might have been
4630 reset if the block had errors and was cleaned up. */
4631 gfc_current_ns = my_parent;
4632
4633 pop_state ();
4634 }
4635
4636
4637 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4638 behind the scenes with compiler-generated variables. */
4639
4640 static void
parse_associate(void)4641 parse_associate (void)
4642 {
4643 gfc_namespace* my_ns;
4644 gfc_state_data s;
4645 gfc_statement st;
4646 gfc_association_list* a;
4647
4648 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
4649
4650 my_ns = gfc_build_block_ns (gfc_current_ns);
4651
4652 new_st.op = EXEC_BLOCK;
4653 new_st.ext.block.ns = my_ns;
4654 gcc_assert (new_st.ext.block.assoc);
4655
4656 /* Add all associate-names as BLOCK variables. Creating them is enough
4657 for now, they'll get their values during trans-* phase. */
4658 gfc_current_ns = my_ns;
4659 for (a = new_st.ext.block.assoc; a; a = a->next)
4660 {
4661 gfc_symbol* sym;
4662 gfc_ref *ref;
4663 gfc_array_ref *array_ref;
4664
4665 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
4666 gcc_unreachable ();
4667
4668 sym = a->st->n.sym;
4669 sym->attr.flavor = FL_VARIABLE;
4670 sym->assoc = a;
4671 sym->declared_at = a->where;
4672 gfc_set_sym_referenced (sym);
4673
4674 /* Initialize the typespec. It is not available in all cases,
4675 however, as it may only be set on the target during resolution.
4676 Still, sometimes it helps to have it right now -- especially
4677 for parsing component references on the associate-name
4678 in case of association to a derived-type. */
4679 sym->ts = a->target->ts;
4680
4681 /* Check if the target expression is array valued. This cannot always
4682 be done by looking at target.rank, because that might not have been
4683 set yet. Therefore traverse the chain of refs, looking for the last
4684 array ref and evaluate that. */
4685 array_ref = NULL;
4686 for (ref = a->target->ref; ref; ref = ref->next)
4687 if (ref->type == REF_ARRAY)
4688 array_ref = &ref->u.ar;
4689 if (array_ref || a->target->rank)
4690 {
4691 gfc_array_spec *as;
4692 int dim, rank = 0;
4693 if (array_ref)
4694 {
4695 a->rankguessed = 1;
4696 /* Count the dimension, that have a non-scalar extend. */
4697 for (dim = 0; dim < array_ref->dimen; ++dim)
4698 if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
4699 && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
4700 && array_ref->end[dim] == NULL
4701 && array_ref->start[dim] != NULL))
4702 ++rank;
4703 }
4704 else
4705 rank = a->target->rank;
4706 /* When the rank is greater than zero then sym will be an array. */
4707 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
4708 {
4709 if ((!CLASS_DATA (sym)->as && rank != 0)
4710 || (CLASS_DATA (sym)->as
4711 && CLASS_DATA (sym)->as->rank != rank))
4712 {
4713 /* Don't just (re-)set the attr and as in the sym.ts,
4714 because this modifies the target's attr and as. Copy the
4715 data and do a build_class_symbol. */
4716 symbol_attribute attr = CLASS_DATA (a->target)->attr;
4717 int corank = gfc_get_corank (a->target);
4718 gfc_typespec type;
4719
4720 if (rank || corank)
4721 {
4722 as = gfc_get_array_spec ();
4723 as->type = AS_DEFERRED;
4724 as->rank = rank;
4725 as->corank = corank;
4726 attr.dimension = rank ? 1 : 0;
4727 attr.codimension = corank ? 1 : 0;
4728 }
4729 else
4730 {
4731 as = NULL;
4732 attr.dimension = attr.codimension = 0;
4733 }
4734 attr.class_ok = 0;
4735 type = CLASS_DATA (sym)->ts;
4736 if (!gfc_build_class_symbol (&type,
4737 &attr, &as))
4738 gcc_unreachable ();
4739 sym->ts = type;
4740 sym->ts.type = BT_CLASS;
4741 sym->attr.class_ok = 1;
4742 }
4743 else
4744 sym->attr.class_ok = 1;
4745 }
4746 else if ((!sym->as && rank != 0)
4747 || (sym->as && sym->as->rank != rank))
4748 {
4749 as = gfc_get_array_spec ();
4750 as->type = AS_DEFERRED;
4751 as->rank = rank;
4752 as->corank = gfc_get_corank (a->target);
4753 sym->as = as;
4754 sym->attr.dimension = 1;
4755 if (as->corank)
4756 sym->attr.codimension = 1;
4757 }
4758 }
4759 }
4760
4761 accept_statement (ST_ASSOCIATE);
4762 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
4763
4764 loop:
4765 st = parse_executable (ST_NONE);
4766 switch (st)
4767 {
4768 case ST_NONE:
4769 unexpected_eof ();
4770
4771 case_end:
4772 accept_statement (st);
4773 my_ns->code = gfc_state_stack->head;
4774 break;
4775
4776 default:
4777 unexpected_statement (st);
4778 goto loop;
4779 }
4780
4781 gfc_current_ns = gfc_current_ns->parent;
4782 pop_state ();
4783 }
4784
4785
4786 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4787 handled inside of parse_executable(), because they aren't really
4788 loop statements. */
4789
4790 static void
parse_do_block(void)4791 parse_do_block (void)
4792 {
4793 gfc_statement st;
4794 gfc_code *top;
4795 gfc_state_data s;
4796 gfc_symtree *stree;
4797 gfc_exec_op do_op;
4798
4799 do_op = new_st.op;
4800 s.ext.end_do_label = new_st.label1;
4801
4802 if (new_st.ext.iterator != NULL)
4803 {
4804 stree = new_st.ext.iterator->var->symtree;
4805 if (directive_unroll != -1)
4806 {
4807 new_st.ext.iterator->unroll = directive_unroll;
4808 directive_unroll = -1;
4809 }
4810 if (directive_ivdep)
4811 {
4812 new_st.ext.iterator->ivdep = directive_ivdep;
4813 directive_ivdep = false;
4814 }
4815 if (directive_vector)
4816 {
4817 new_st.ext.iterator->vector = directive_vector;
4818 directive_vector = false;
4819 }
4820 if (directive_novector)
4821 {
4822 new_st.ext.iterator->novector = directive_novector;
4823 directive_novector = false;
4824 }
4825 }
4826 else
4827 stree = NULL;
4828
4829 accept_statement (ST_DO);
4830
4831 top = gfc_state_stack->tail;
4832 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
4833 gfc_new_block);
4834
4835 s.do_variable = stree;
4836
4837 top->block = new_level (top);
4838 top->block->op = EXEC_DO;
4839
4840 loop:
4841 st = parse_executable (ST_NONE);
4842
4843 switch (st)
4844 {
4845 case ST_NONE:
4846 unexpected_eof ();
4847
4848 case ST_ENDDO:
4849 if (s.ext.end_do_label != NULL
4850 && s.ext.end_do_label != gfc_statement_label)
4851 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4852 "DO label");
4853
4854 if (gfc_statement_label != NULL)
4855 {
4856 new_st.op = EXEC_NOP;
4857 add_statement ();
4858 }
4859 break;
4860
4861 case ST_IMPLIED_ENDDO:
4862 /* If the do-stmt of this DO construct has a do-construct-name,
4863 the corresponding end-do must be an end-do-stmt (with a matching
4864 name, but in that case we must have seen ST_ENDDO first).
4865 We only complain about this in pedantic mode. */
4866 if (gfc_current_block () != NULL)
4867 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4868 &gfc_current_block()->declared_at);
4869
4870 break;
4871
4872 default:
4873 unexpected_statement (st);
4874 goto loop;
4875 }
4876
4877 pop_state ();
4878 accept_statement (st);
4879 }
4880
4881
4882 /* Parse the statements of OpenMP do/parallel do. */
4883
4884 static gfc_statement
parse_omp_do(gfc_statement omp_st)4885 parse_omp_do (gfc_statement omp_st)
4886 {
4887 gfc_statement st;
4888 gfc_code *cp, *np;
4889 gfc_state_data s;
4890
4891 accept_statement (omp_st);
4892
4893 cp = gfc_state_stack->tail;
4894 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
4895 np = new_level (cp);
4896 np->op = cp->op;
4897 np->block = NULL;
4898
4899 for (;;)
4900 {
4901 st = next_statement ();
4902 if (st == ST_NONE)
4903 unexpected_eof ();
4904 else if (st == ST_DO)
4905 break;
4906 else
4907 unexpected_statement (st);
4908 }
4909
4910 parse_do_block ();
4911 if (gfc_statement_label != NULL
4912 && gfc_state_stack->previous != NULL
4913 && gfc_state_stack->previous->state == COMP_DO
4914 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
4915 {
4916 /* In
4917 DO 100 I=1,10
4918 !$OMP DO
4919 DO J=1,10
4920 ...
4921 100 CONTINUE
4922 there should be no !$OMP END DO. */
4923 pop_state ();
4924 return ST_IMPLIED_ENDDO;
4925 }
4926
4927 check_do_closure ();
4928 pop_state ();
4929
4930 st = next_statement ();
4931 gfc_statement omp_end_st = ST_OMP_END_DO;
4932 switch (omp_st)
4933 {
4934 case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
4935 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4936 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
4937 break;
4938 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4939 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
4940 break;
4941 case ST_OMP_DISTRIBUTE_SIMD:
4942 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
4943 break;
4944 case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
4945 case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
4946 case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
4947 case ST_OMP_PARALLEL_DO_SIMD:
4948 omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
4949 break;
4950 case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
4951 case ST_OMP_TARGET_PARALLEL_DO:
4952 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
4953 break;
4954 case ST_OMP_TARGET_PARALLEL_DO_SIMD:
4955 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
4956 break;
4957 case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
4958 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4959 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
4960 break;
4961 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4962 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
4963 break;
4964 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4965 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4966 break;
4967 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4968 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
4969 break;
4970 case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
4971 case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
4972 case ST_OMP_TEAMS_DISTRIBUTE:
4973 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
4974 break;
4975 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4976 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
4977 break;
4978 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4979 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4980 break;
4981 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
4982 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
4983 break;
4984 default: gcc_unreachable ();
4985 }
4986 if (st == omp_end_st)
4987 {
4988 if (new_st.op == EXEC_OMP_END_NOWAIT)
4989 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
4990 else
4991 gcc_assert (new_st.op == EXEC_NOP);
4992 gfc_clear_new_st ();
4993 gfc_commit_symbols ();
4994 gfc_warning_check ();
4995 st = next_statement ();
4996 }
4997 return st;
4998 }
4999
5000
5001 /* Parse the statements of OpenMP atomic directive. */
5002
5003 static gfc_statement
parse_omp_oacc_atomic(bool omp_p)5004 parse_omp_oacc_atomic (bool omp_p)
5005 {
5006 gfc_statement st, st_atomic, st_end_atomic;
5007 gfc_code *cp, *np;
5008 gfc_state_data s;
5009 int count;
5010
5011 if (omp_p)
5012 {
5013 st_atomic = ST_OMP_ATOMIC;
5014 st_end_atomic = ST_OMP_END_ATOMIC;
5015 }
5016 else
5017 {
5018 st_atomic = ST_OACC_ATOMIC;
5019 st_end_atomic = ST_OACC_END_ATOMIC;
5020 }
5021 accept_statement (st_atomic);
5022
5023 cp = gfc_state_stack->tail;
5024 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5025 np = new_level (cp);
5026 np->op = cp->op;
5027 np->block = NULL;
5028 np->ext.omp_atomic = cp->ext.omp_atomic;
5029 count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
5030 == GFC_OMP_ATOMIC_CAPTURE);
5031
5032 while (count)
5033 {
5034 st = next_statement ();
5035 if (st == ST_NONE)
5036 unexpected_eof ();
5037 else if (st == ST_ASSIGNMENT)
5038 {
5039 accept_statement (st);
5040 count--;
5041 }
5042 else
5043 unexpected_statement (st);
5044 }
5045
5046 pop_state ();
5047
5048 st = next_statement ();
5049 if (st == st_end_atomic)
5050 {
5051 gfc_clear_new_st ();
5052 gfc_commit_symbols ();
5053 gfc_warning_check ();
5054 st = next_statement ();
5055 }
5056 else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
5057 == GFC_OMP_ATOMIC_CAPTURE)
5058 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
5059 return st;
5060 }
5061
5062
5063 /* Parse the statements of an OpenACC structured block. */
5064
5065 static void
parse_oacc_structured_block(gfc_statement acc_st)5066 parse_oacc_structured_block (gfc_statement acc_st)
5067 {
5068 gfc_statement st, acc_end_st;
5069 gfc_code *cp, *np;
5070 gfc_state_data s, *sd;
5071
5072 for (sd = gfc_state_stack; sd; sd = sd->previous)
5073 if (sd->state == COMP_CRITICAL)
5074 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5075
5076 accept_statement (acc_st);
5077
5078 cp = gfc_state_stack->tail;
5079 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5080 np = new_level (cp);
5081 np->op = cp->op;
5082 np->block = NULL;
5083 switch (acc_st)
5084 {
5085 case ST_OACC_PARALLEL:
5086 acc_end_st = ST_OACC_END_PARALLEL;
5087 break;
5088 case ST_OACC_KERNELS:
5089 acc_end_st = ST_OACC_END_KERNELS;
5090 break;
5091 case ST_OACC_SERIAL:
5092 acc_end_st = ST_OACC_END_SERIAL;
5093 break;
5094 case ST_OACC_DATA:
5095 acc_end_st = ST_OACC_END_DATA;
5096 break;
5097 case ST_OACC_HOST_DATA:
5098 acc_end_st = ST_OACC_END_HOST_DATA;
5099 break;
5100 default:
5101 gcc_unreachable ();
5102 }
5103
5104 do
5105 {
5106 st = parse_executable (ST_NONE);
5107 if (st == ST_NONE)
5108 unexpected_eof ();
5109 else if (st != acc_end_st)
5110 {
5111 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
5112 reject_statement ();
5113 }
5114 }
5115 while (st != acc_end_st);
5116
5117 gcc_assert (new_st.op == EXEC_NOP);
5118
5119 gfc_clear_new_st ();
5120 gfc_commit_symbols ();
5121 gfc_warning_check ();
5122 pop_state ();
5123 }
5124
5125 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5126
5127 static gfc_statement
parse_oacc_loop(gfc_statement acc_st)5128 parse_oacc_loop (gfc_statement acc_st)
5129 {
5130 gfc_statement st;
5131 gfc_code *cp, *np;
5132 gfc_state_data s, *sd;
5133
5134 for (sd = gfc_state_stack; sd; sd = sd->previous)
5135 if (sd->state == COMP_CRITICAL)
5136 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5137
5138 accept_statement (acc_st);
5139
5140 cp = gfc_state_stack->tail;
5141 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5142 np = new_level (cp);
5143 np->op = cp->op;
5144 np->block = NULL;
5145
5146 for (;;)
5147 {
5148 st = next_statement ();
5149 if (st == ST_NONE)
5150 unexpected_eof ();
5151 else if (st == ST_DO)
5152 break;
5153 else
5154 {
5155 gfc_error ("Expected DO loop at %C");
5156 reject_statement ();
5157 }
5158 }
5159
5160 parse_do_block ();
5161 if (gfc_statement_label != NULL
5162 && gfc_state_stack->previous != NULL
5163 && gfc_state_stack->previous->state == COMP_DO
5164 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5165 {
5166 pop_state ();
5167 return ST_IMPLIED_ENDDO;
5168 }
5169
5170 check_do_closure ();
5171 pop_state ();
5172
5173 st = next_statement ();
5174 if (st == ST_OACC_END_LOOP)
5175 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5176 if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
5177 (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
5178 (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
5179 (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
5180 {
5181 gcc_assert (new_st.op == EXEC_NOP);
5182 gfc_clear_new_st ();
5183 gfc_commit_symbols ();
5184 gfc_warning_check ();
5185 st = next_statement ();
5186 }
5187 return st;
5188 }
5189
5190
5191 /* Parse the statements of an OpenMP structured block. */
5192
5193 static void
parse_omp_structured_block(gfc_statement omp_st,bool workshare_stmts_only)5194 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
5195 {
5196 gfc_statement st, omp_end_st;
5197 gfc_code *cp, *np;
5198 gfc_state_data s;
5199
5200 accept_statement (omp_st);
5201
5202 cp = gfc_state_stack->tail;
5203 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5204 np = new_level (cp);
5205 np->op = cp->op;
5206 np->block = NULL;
5207
5208 switch (omp_st)
5209 {
5210 case ST_OMP_PARALLEL:
5211 omp_end_st = ST_OMP_END_PARALLEL;
5212 break;
5213 case ST_OMP_PARALLEL_SECTIONS:
5214 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
5215 break;
5216 case ST_OMP_SECTIONS:
5217 omp_end_st = ST_OMP_END_SECTIONS;
5218 break;
5219 case ST_OMP_ORDERED:
5220 omp_end_st = ST_OMP_END_ORDERED;
5221 break;
5222 case ST_OMP_CRITICAL:
5223 omp_end_st = ST_OMP_END_CRITICAL;
5224 break;
5225 case ST_OMP_MASTER:
5226 omp_end_st = ST_OMP_END_MASTER;
5227 break;
5228 case ST_OMP_SINGLE:
5229 omp_end_st = ST_OMP_END_SINGLE;
5230 break;
5231 case ST_OMP_TARGET:
5232 omp_end_st = ST_OMP_END_TARGET;
5233 break;
5234 case ST_OMP_TARGET_DATA:
5235 omp_end_st = ST_OMP_END_TARGET_DATA;
5236 break;
5237 case ST_OMP_TARGET_PARALLEL:
5238 omp_end_st = ST_OMP_END_TARGET_PARALLEL;
5239 break;
5240 case ST_OMP_TARGET_TEAMS:
5241 omp_end_st = ST_OMP_END_TARGET_TEAMS;
5242 break;
5243 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5244 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
5245 break;
5246 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5247 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5248 break;
5249 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5250 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5251 break;
5252 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5253 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
5254 break;
5255 case ST_OMP_TASK:
5256 omp_end_st = ST_OMP_END_TASK;
5257 break;
5258 case ST_OMP_TASKGROUP:
5259 omp_end_st = ST_OMP_END_TASKGROUP;
5260 break;
5261 case ST_OMP_TEAMS:
5262 omp_end_st = ST_OMP_END_TEAMS;
5263 break;
5264 case ST_OMP_TEAMS_DISTRIBUTE:
5265 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5266 break;
5267 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5268 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
5269 break;
5270 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5271 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5272 break;
5273 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5274 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5275 break;
5276 case ST_OMP_DISTRIBUTE:
5277 omp_end_st = ST_OMP_END_DISTRIBUTE;
5278 break;
5279 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5280 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
5281 break;
5282 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5283 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
5284 break;
5285 case ST_OMP_DISTRIBUTE_SIMD:
5286 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
5287 break;
5288 case ST_OMP_WORKSHARE:
5289 omp_end_st = ST_OMP_END_WORKSHARE;
5290 break;
5291 case ST_OMP_PARALLEL_WORKSHARE:
5292 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
5293 break;
5294 default:
5295 gcc_unreachable ();
5296 }
5297
5298 do
5299 {
5300 if (workshare_stmts_only)
5301 {
5302 /* Inside of !$omp workshare, only
5303 scalar assignments
5304 array assignments
5305 where statements and constructs
5306 forall statements and constructs
5307 !$omp atomic
5308 !$omp critical
5309 !$omp parallel
5310 are allowed. For !$omp critical these
5311 restrictions apply recursively. */
5312 bool cycle = true;
5313
5314 st = next_statement ();
5315 for (;;)
5316 {
5317 switch (st)
5318 {
5319 case ST_NONE:
5320 unexpected_eof ();
5321
5322 case ST_ASSIGNMENT:
5323 case ST_WHERE:
5324 case ST_FORALL:
5325 accept_statement (st);
5326 break;
5327
5328 case ST_WHERE_BLOCK:
5329 parse_where_block ();
5330 break;
5331
5332 case ST_FORALL_BLOCK:
5333 parse_forall_block ();
5334 break;
5335
5336 case ST_OMP_PARALLEL:
5337 case ST_OMP_PARALLEL_SECTIONS:
5338 parse_omp_structured_block (st, false);
5339 break;
5340
5341 case ST_OMP_PARALLEL_WORKSHARE:
5342 case ST_OMP_CRITICAL:
5343 parse_omp_structured_block (st, true);
5344 break;
5345
5346 case ST_OMP_PARALLEL_DO:
5347 case ST_OMP_PARALLEL_DO_SIMD:
5348 st = parse_omp_do (st);
5349 continue;
5350
5351 case ST_OMP_ATOMIC:
5352 st = parse_omp_oacc_atomic (true);
5353 continue;
5354
5355 default:
5356 cycle = false;
5357 break;
5358 }
5359
5360 if (!cycle)
5361 break;
5362
5363 st = next_statement ();
5364 }
5365 }
5366 else
5367 st = parse_executable (ST_NONE);
5368 if (st == ST_NONE)
5369 unexpected_eof ();
5370 else if (st == ST_OMP_SECTION
5371 && (omp_st == ST_OMP_SECTIONS
5372 || omp_st == ST_OMP_PARALLEL_SECTIONS))
5373 {
5374 np = new_level (np);
5375 np->op = cp->op;
5376 np->block = NULL;
5377 }
5378 else if (st != omp_end_st)
5379 unexpected_statement (st);
5380 }
5381 while (st != omp_end_st);
5382
5383 switch (new_st.op)
5384 {
5385 case EXEC_OMP_END_NOWAIT:
5386 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5387 break;
5388 case EXEC_OMP_END_CRITICAL:
5389 if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL))
5390 || (new_st.ext.omp_name != NULL
5391 && strcmp (cp->ext.omp_clauses->critical_name,
5392 new_st.ext.omp_name) != 0))
5393 gfc_error ("Name after !$omp critical and !$omp end critical does "
5394 "not match at %C");
5395 free (CONST_CAST (char *, new_st.ext.omp_name));
5396 new_st.ext.omp_name = NULL;
5397 break;
5398 case EXEC_OMP_END_SINGLE:
5399 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
5400 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
5401 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
5402 gfc_free_omp_clauses (new_st.ext.omp_clauses);
5403 break;
5404 case EXEC_NOP:
5405 break;
5406 default:
5407 gcc_unreachable ();
5408 }
5409
5410 gfc_clear_new_st ();
5411 gfc_commit_symbols ();
5412 gfc_warning_check ();
5413 pop_state ();
5414 }
5415
5416
5417 /* Accept a series of executable statements. We return the first
5418 statement that doesn't fit to the caller. Any block statements are
5419 passed on to the correct handler, which usually passes the buck
5420 right back here. */
5421
5422 static gfc_statement
parse_executable(gfc_statement st)5423 parse_executable (gfc_statement st)
5424 {
5425 int close_flag;
5426
5427 if (st == ST_NONE)
5428 st = next_statement ();
5429
5430 for (;;)
5431 {
5432 close_flag = check_do_closure ();
5433 if (close_flag)
5434 switch (st)
5435 {
5436 case ST_GOTO:
5437 case ST_END_PROGRAM:
5438 case ST_RETURN:
5439 case ST_EXIT:
5440 case ST_END_FUNCTION:
5441 case ST_CYCLE:
5442 case ST_PAUSE:
5443 case ST_STOP:
5444 case ST_ERROR_STOP:
5445 case ST_END_SUBROUTINE:
5446
5447 case ST_DO:
5448 case ST_FORALL:
5449 case ST_WHERE:
5450 case ST_SELECT_CASE:
5451 gfc_error ("%s statement at %C cannot terminate a non-block "
5452 "DO loop", gfc_ascii_statement (st));
5453 break;
5454
5455 default:
5456 break;
5457 }
5458
5459 switch (st)
5460 {
5461 case ST_NONE:
5462 unexpected_eof ();
5463
5464 case ST_DATA:
5465 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
5466 "first executable statement");
5467 /* Fall through. */
5468
5469 case ST_FORMAT:
5470 case ST_ENTRY:
5471 case_executable:
5472 accept_statement (st);
5473 if (close_flag == 1)
5474 return ST_IMPLIED_ENDDO;
5475 break;
5476
5477 case ST_BLOCK:
5478 parse_block_construct ();
5479 break;
5480
5481 case ST_ASSOCIATE:
5482 parse_associate ();
5483 break;
5484
5485 case ST_IF_BLOCK:
5486 parse_if_block ();
5487 break;
5488
5489 case ST_SELECT_CASE:
5490 parse_select_block ();
5491 break;
5492
5493 case ST_SELECT_TYPE:
5494 parse_select_type_block ();
5495 break;
5496
5497 case ST_SELECT_RANK:
5498 parse_select_rank_block ();
5499 break;
5500
5501 case ST_DO:
5502 parse_do_block ();
5503 if (check_do_closure () == 1)
5504 return ST_IMPLIED_ENDDO;
5505 break;
5506
5507 case ST_CRITICAL:
5508 parse_critical_block ();
5509 break;
5510
5511 case ST_WHERE_BLOCK:
5512 parse_where_block ();
5513 break;
5514
5515 case ST_FORALL_BLOCK:
5516 parse_forall_block ();
5517 break;
5518
5519 case ST_OACC_PARALLEL_LOOP:
5520 case ST_OACC_KERNELS_LOOP:
5521 case ST_OACC_SERIAL_LOOP:
5522 case ST_OACC_LOOP:
5523 st = parse_oacc_loop (st);
5524 if (st == ST_IMPLIED_ENDDO)
5525 return st;
5526 continue;
5527
5528 case ST_OACC_PARALLEL:
5529 case ST_OACC_KERNELS:
5530 case ST_OACC_SERIAL:
5531 case ST_OACC_DATA:
5532 case ST_OACC_HOST_DATA:
5533 parse_oacc_structured_block (st);
5534 break;
5535
5536 case ST_OMP_PARALLEL:
5537 case ST_OMP_PARALLEL_SECTIONS:
5538 case ST_OMP_SECTIONS:
5539 case ST_OMP_ORDERED:
5540 case ST_OMP_CRITICAL:
5541 case ST_OMP_MASTER:
5542 case ST_OMP_SINGLE:
5543 case ST_OMP_TARGET:
5544 case ST_OMP_TARGET_DATA:
5545 case ST_OMP_TARGET_PARALLEL:
5546 case ST_OMP_TARGET_TEAMS:
5547 case ST_OMP_TEAMS:
5548 case ST_OMP_TASK:
5549 case ST_OMP_TASKGROUP:
5550 parse_omp_structured_block (st, false);
5551 break;
5552
5553 case ST_OMP_WORKSHARE:
5554 case ST_OMP_PARALLEL_WORKSHARE:
5555 parse_omp_structured_block (st, true);
5556 break;
5557
5558 case ST_OMP_DISTRIBUTE:
5559 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5560 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5561 case ST_OMP_DISTRIBUTE_SIMD:
5562 case ST_OMP_DO:
5563 case ST_OMP_DO_SIMD:
5564 case ST_OMP_PARALLEL_DO:
5565 case ST_OMP_PARALLEL_DO_SIMD:
5566 case ST_OMP_SIMD:
5567 case ST_OMP_TARGET_PARALLEL_DO:
5568 case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5569 case ST_OMP_TARGET_SIMD:
5570 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5571 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5572 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5573 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5574 case ST_OMP_TASKLOOP:
5575 case ST_OMP_TASKLOOP_SIMD:
5576 case ST_OMP_TEAMS_DISTRIBUTE:
5577 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5578 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5579 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5580 st = parse_omp_do (st);
5581 if (st == ST_IMPLIED_ENDDO)
5582 return st;
5583 continue;
5584
5585 case ST_OACC_ATOMIC:
5586 st = parse_omp_oacc_atomic (false);
5587 continue;
5588
5589 case ST_OMP_ATOMIC:
5590 st = parse_omp_oacc_atomic (true);
5591 continue;
5592
5593 default:
5594 return st;
5595 }
5596
5597 if (directive_unroll != -1)
5598 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5599
5600 if (directive_ivdep)
5601 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5602
5603 if (directive_vector)
5604 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5605
5606 if (directive_novector)
5607 gfc_error ("%<GCC novector%> "
5608 "directive not at the start of a loop at %C");
5609
5610 st = next_statement ();
5611 }
5612 }
5613
5614
5615 /* Fix the symbols for sibling functions. These are incorrectly added to
5616 the child namespace as the parser didn't know about this procedure. */
5617
5618 static void
gfc_fixup_sibling_symbols(gfc_symbol * sym,gfc_namespace * siblings)5619 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
5620 {
5621 gfc_namespace *ns;
5622 gfc_symtree *st;
5623 gfc_symbol *old_sym;
5624
5625 for (ns = siblings; ns; ns = ns->sibling)
5626 {
5627 st = gfc_find_symtree (ns->sym_root, sym->name);
5628
5629 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
5630 goto fixup_contained;
5631
5632 if ((st->n.sym->attr.flavor == FL_DERIVED
5633 && sym->attr.generic && sym->attr.function)
5634 ||(sym->attr.flavor == FL_DERIVED
5635 && st->n.sym->attr.generic && st->n.sym->attr.function))
5636 goto fixup_contained;
5637
5638 old_sym = st->n.sym;
5639 if (old_sym->ns == ns
5640 && !old_sym->attr.contained
5641
5642 /* By 14.6.1.3, host association should be excluded
5643 for the following. */
5644 && !(old_sym->attr.external
5645 || (old_sym->ts.type != BT_UNKNOWN
5646 && !old_sym->attr.implicit_type)
5647 || old_sym->attr.flavor == FL_PARAMETER
5648 || old_sym->attr.use_assoc
5649 || old_sym->attr.in_common
5650 || old_sym->attr.in_equivalence
5651 || old_sym->attr.data
5652 || old_sym->attr.dummy
5653 || old_sym->attr.result
5654 || old_sym->attr.dimension
5655 || old_sym->attr.allocatable
5656 || old_sym->attr.intrinsic
5657 || old_sym->attr.generic
5658 || old_sym->attr.flavor == FL_NAMELIST
5659 || old_sym->attr.flavor == FL_LABEL
5660 || old_sym->attr.proc == PROC_ST_FUNCTION))
5661 {
5662 /* Replace it with the symbol from the parent namespace. */
5663 st->n.sym = sym;
5664 sym->refs++;
5665
5666 gfc_release_symbol (old_sym);
5667 }
5668
5669 fixup_contained:
5670 /* Do the same for any contained procedures. */
5671 gfc_fixup_sibling_symbols (sym, ns->contained);
5672 }
5673 }
5674
5675 static void
parse_contained(int module)5676 parse_contained (int module)
5677 {
5678 gfc_namespace *ns, *parent_ns, *tmp;
5679 gfc_state_data s1, s2;
5680 gfc_statement st;
5681 gfc_symbol *sym;
5682 gfc_entry_list *el;
5683 locus old_loc;
5684 int contains_statements = 0;
5685 int seen_error = 0;
5686
5687 push_state (&s1, COMP_CONTAINS, NULL);
5688 parent_ns = gfc_current_ns;
5689
5690 do
5691 {
5692 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
5693
5694 gfc_current_ns->sibling = parent_ns->contained;
5695 parent_ns->contained = gfc_current_ns;
5696
5697 next:
5698 /* Process the next available statement. We come here if we got an error
5699 and rejected the last statement. */
5700 old_loc = gfc_current_locus;
5701 st = next_statement ();
5702
5703 switch (st)
5704 {
5705 case ST_NONE:
5706 unexpected_eof ();
5707
5708 case ST_FUNCTION:
5709 case ST_SUBROUTINE:
5710 contains_statements = 1;
5711 accept_statement (st);
5712
5713 push_state (&s2,
5714 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
5715 gfc_new_block);
5716
5717 /* For internal procedures, create/update the symbol in the
5718 parent namespace. */
5719
5720 if (!module)
5721 {
5722 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
5723 gfc_error ("Contained procedure %qs at %C is already "
5724 "ambiguous", gfc_new_block->name);
5725 else
5726 {
5727 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
5728 sym->name,
5729 &gfc_new_block->declared_at))
5730 {
5731 if (st == ST_FUNCTION)
5732 gfc_add_function (&sym->attr, sym->name,
5733 &gfc_new_block->declared_at);
5734 else
5735 gfc_add_subroutine (&sym->attr, sym->name,
5736 &gfc_new_block->declared_at);
5737 }
5738 }
5739
5740 gfc_commit_symbols ();
5741 }
5742 else
5743 sym = gfc_new_block;
5744
5745 /* Mark this as a contained function, so it isn't replaced
5746 by other module functions. */
5747 sym->attr.contained = 1;
5748
5749 /* Set implicit_pure so that it can be reset if any of the
5750 tests for purity fail. This is used for some optimisation
5751 during translation. */
5752 if (!sym->attr.pure)
5753 sym->attr.implicit_pure = 1;
5754
5755 parse_progunit (ST_NONE);
5756
5757 /* Fix up any sibling functions that refer to this one. */
5758 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
5759 /* Or refer to any of its alternate entry points. */
5760 for (el = gfc_current_ns->entries; el; el = el->next)
5761 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
5762
5763 gfc_current_ns->code = s2.head;
5764 gfc_current_ns = parent_ns;
5765
5766 pop_state ();
5767 break;
5768
5769 /* These statements are associated with the end of the host unit. */
5770 case ST_END_FUNCTION:
5771 case ST_END_MODULE:
5772 case ST_END_SUBMODULE:
5773 case ST_END_PROGRAM:
5774 case ST_END_SUBROUTINE:
5775 accept_statement (st);
5776 gfc_current_ns->code = s1.head;
5777 break;
5778
5779 default:
5780 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5781 gfc_ascii_statement (st));
5782 reject_statement ();
5783 seen_error = 1;
5784 goto next;
5785 break;
5786 }
5787 }
5788 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
5789 && st != ST_END_MODULE && st != ST_END_SUBMODULE
5790 && st != ST_END_PROGRAM);
5791
5792 /* The first namespace in the list is guaranteed to not have
5793 anything (worthwhile) in it. */
5794 tmp = gfc_current_ns;
5795 gfc_current_ns = parent_ns;
5796 if (seen_error && tmp->refs > 1)
5797 gfc_free_namespace (tmp);
5798
5799 ns = gfc_current_ns->contained;
5800 gfc_current_ns->contained = ns->sibling;
5801 gfc_free_namespace (ns);
5802
5803 pop_state ();
5804 if (!contains_statements)
5805 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
5806 "FUNCTION or SUBROUTINE statement at %L", &old_loc);
5807 }
5808
5809
5810 /* The result variable in a MODULE PROCEDURE needs to be created and
5811 its characteristics copied from the interface since it is neither
5812 declared in the procedure declaration nor in the specification
5813 part. */
5814
5815 static void
get_modproc_result(void)5816 get_modproc_result (void)
5817 {
5818 gfc_symbol *proc;
5819 if (gfc_state_stack->previous
5820 && gfc_state_stack->previous->state == COMP_CONTAINS
5821 && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
5822 {
5823 proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
5824 if (proc != NULL
5825 && proc->attr.function
5826 && proc->tlink
5827 && proc->tlink->result
5828 && proc->tlink->result != proc->tlink)
5829 {
5830 gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
5831 gfc_set_sym_referenced (proc->result);
5832 proc->result->attr.if_source = IFSRC_DECL;
5833 gfc_commit_symbol (proc->result);
5834 }
5835 }
5836 }
5837
5838
5839 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5840
5841 static void
parse_progunit(gfc_statement st)5842 parse_progunit (gfc_statement st)
5843 {
5844 gfc_state_data *p;
5845 int n;
5846
5847 gfc_adjust_builtins ();
5848
5849 if (gfc_new_block
5850 && gfc_new_block->abr_modproc_decl
5851 && gfc_new_block->attr.function)
5852 get_modproc_result ();
5853
5854 st = parse_spec (st);
5855 switch (st)
5856 {
5857 case ST_NONE:
5858 unexpected_eof ();
5859
5860 case ST_CONTAINS:
5861 /* This is not allowed within BLOCK! */
5862 if (gfc_current_state () != COMP_BLOCK)
5863 goto contains;
5864 break;
5865
5866 case_end:
5867 accept_statement (st);
5868 goto done;
5869
5870 default:
5871 break;
5872 }
5873
5874 if (gfc_current_state () == COMP_FUNCTION)
5875 gfc_check_function_type (gfc_current_ns);
5876
5877 loop:
5878 for (;;)
5879 {
5880 st = parse_executable (st);
5881
5882 switch (st)
5883 {
5884 case ST_NONE:
5885 unexpected_eof ();
5886
5887 case ST_CONTAINS:
5888 /* This is not allowed within BLOCK! */
5889 if (gfc_current_state () != COMP_BLOCK)
5890 goto contains;
5891 break;
5892
5893 case_end:
5894 accept_statement (st);
5895 goto done;
5896
5897 default:
5898 break;
5899 }
5900
5901 unexpected_statement (st);
5902 reject_statement ();
5903 st = next_statement ();
5904 }
5905
5906 contains:
5907 n = 0;
5908
5909 for (p = gfc_state_stack; p; p = p->previous)
5910 if (p->state == COMP_CONTAINS)
5911 n++;
5912
5913 if (gfc_find_state (COMP_MODULE) == true
5914 || gfc_find_state (COMP_SUBMODULE) == true)
5915 n--;
5916
5917 if (n > 0)
5918 {
5919 gfc_error ("CONTAINS statement at %C is already in a contained "
5920 "program unit");
5921 reject_statement ();
5922 st = next_statement ();
5923 goto loop;
5924 }
5925
5926 parse_contained (0);
5927
5928 done:
5929 gfc_current_ns->code = gfc_state_stack->head;
5930 }
5931
5932
5933 /* Come here to complain about a global symbol already in use as
5934 something else. */
5935
5936 void
gfc_global_used(gfc_gsymbol * sym,locus * where)5937 gfc_global_used (gfc_gsymbol *sym, locus *where)
5938 {
5939 const char *name;
5940
5941 if (where == NULL)
5942 where = &gfc_current_locus;
5943
5944 switch(sym->type)
5945 {
5946 case GSYM_PROGRAM:
5947 name = "PROGRAM";
5948 break;
5949 case GSYM_FUNCTION:
5950 name = "FUNCTION";
5951 break;
5952 case GSYM_SUBROUTINE:
5953 name = "SUBROUTINE";
5954 break;
5955 case GSYM_COMMON:
5956 name = "COMMON";
5957 break;
5958 case GSYM_BLOCK_DATA:
5959 name = "BLOCK DATA";
5960 break;
5961 case GSYM_MODULE:
5962 name = "MODULE";
5963 break;
5964 default:
5965 name = NULL;
5966 }
5967
5968 if (name)
5969 {
5970 if (sym->binding_label)
5971 gfc_error ("Global binding name %qs at %L is already being used "
5972 "as a %s at %L", sym->binding_label, where, name,
5973 &sym->where);
5974 else
5975 gfc_error ("Global name %qs at %L is already being used as "
5976 "a %s at %L", sym->name, where, name, &sym->where);
5977 }
5978 else
5979 {
5980 if (sym->binding_label)
5981 gfc_error ("Global binding name %qs at %L is already being used "
5982 "at %L", sym->binding_label, where, &sym->where);
5983 else
5984 gfc_error ("Global name %qs at %L is already being used at %L",
5985 sym->name, where, &sym->where);
5986 }
5987 }
5988
5989
5990 /* Parse a block data program unit. */
5991
5992 static void
parse_block_data(void)5993 parse_block_data (void)
5994 {
5995 gfc_statement st;
5996 static locus blank_locus;
5997 static int blank_block=0;
5998 gfc_gsymbol *s;
5999
6000 gfc_current_ns->proc_name = gfc_new_block;
6001 gfc_current_ns->is_block_data = 1;
6002
6003 if (gfc_new_block == NULL)
6004 {
6005 if (blank_block)
6006 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6007 "prior BLOCK DATA at %L", &blank_locus);
6008 else
6009 {
6010 blank_block = 1;
6011 blank_locus = gfc_current_locus;
6012 }
6013 }
6014 else
6015 {
6016 s = gfc_get_gsymbol (gfc_new_block->name, false);
6017 if (s->defined
6018 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
6019 gfc_global_used (s, &gfc_new_block->declared_at);
6020 else
6021 {
6022 s->type = GSYM_BLOCK_DATA;
6023 s->where = gfc_new_block->declared_at;
6024 s->defined = 1;
6025 }
6026 }
6027
6028 st = parse_spec (ST_NONE);
6029
6030 while (st != ST_END_BLOCK_DATA)
6031 {
6032 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6033 gfc_ascii_statement (st));
6034 reject_statement ();
6035 st = next_statement ();
6036 }
6037 }
6038
6039
6040 /* Following the association of the ancestor (sub)module symbols, they
6041 must be set host rather than use associated and all must be public.
6042 They are flagged up by 'used_in_submodule' so that they can be set
6043 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6044 linker chokes on multiple symbol definitions. */
6045
6046 static void
set_syms_host_assoc(gfc_symbol * sym)6047 set_syms_host_assoc (gfc_symbol *sym)
6048 {
6049 gfc_component *c;
6050 const char dot[2] = ".";
6051 /* Symbols take the form module.submodule_ or module.name_. */
6052 char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
6053 char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
6054
6055 if (sym == NULL)
6056 return;
6057
6058 if (sym->attr.module_procedure)
6059 sym->attr.external = 0;
6060
6061 sym->attr.use_assoc = 0;
6062 sym->attr.host_assoc = 1;
6063 sym->attr.used_in_submodule =1;
6064
6065 if (sym->attr.flavor == FL_DERIVED)
6066 {
6067 /* Derived types with PRIVATE components that are declared in
6068 modules other than the parent module must not be changed to be
6069 PUBLIC. The 'use-assoc' attribute must be reset so that the
6070 test in symbol.c(gfc_find_component) works correctly. This is
6071 not necessary for PRIVATE symbols since they are not read from
6072 the module. */
6073 memset(parent1, '\0', sizeof(parent1));
6074 memset(parent2, '\0', sizeof(parent2));
6075 strcpy (parent1, gfc_new_block->name);
6076 strcpy (parent2, sym->module);
6077 if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
6078 {
6079 for (c = sym->components; c; c = c->next)
6080 c->attr.access = ACCESS_PUBLIC;
6081 }
6082 else
6083 {
6084 sym->attr.use_assoc = 1;
6085 sym->attr.host_assoc = 0;
6086 }
6087 }
6088 }
6089
6090 /* Parse a module subprogram. */
6091
6092 static void
parse_module(void)6093 parse_module (void)
6094 {
6095 gfc_statement st;
6096 gfc_gsymbol *s;
6097 bool error;
6098
6099 s = gfc_get_gsymbol (gfc_new_block->name, false);
6100 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
6101 gfc_global_used (s, &gfc_new_block->declared_at);
6102 else
6103 {
6104 s->type = GSYM_MODULE;
6105 s->where = gfc_new_block->declared_at;
6106 s->defined = 1;
6107 }
6108
6109 /* Something is nulling the module_list after this point. This is good
6110 since it allows us to 'USE' the parent modules that the submodule
6111 inherits and to set (most) of the symbols as host associated. */
6112 if (gfc_current_state () == COMP_SUBMODULE)
6113 {
6114 use_modules ();
6115 gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
6116 }
6117
6118 st = parse_spec (ST_NONE);
6119
6120 error = false;
6121 loop:
6122 switch (st)
6123 {
6124 case ST_NONE:
6125 unexpected_eof ();
6126
6127 case ST_CONTAINS:
6128 parse_contained (1);
6129 break;
6130
6131 case ST_END_MODULE:
6132 case ST_END_SUBMODULE:
6133 accept_statement (st);
6134 break;
6135
6136 default:
6137 gfc_error ("Unexpected %s statement in MODULE at %C",
6138 gfc_ascii_statement (st));
6139
6140 error = true;
6141 reject_statement ();
6142 st = next_statement ();
6143 goto loop;
6144 }
6145
6146 /* Make sure not to free the namespace twice on error. */
6147 if (!error)
6148 s->ns = gfc_current_ns;
6149 }
6150
6151
6152 /* Add a procedure name to the global symbol table. */
6153
6154 static void
add_global_procedure(bool sub)6155 add_global_procedure (bool sub)
6156 {
6157 gfc_gsymbol *s;
6158
6159 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6160 name is a global identifier. */
6161 if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
6162 {
6163 s = gfc_get_gsymbol (gfc_new_block->name, false);
6164
6165 if (s->defined
6166 || (s->type != GSYM_UNKNOWN
6167 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6168 {
6169 gfc_global_used (s, &gfc_new_block->declared_at);
6170 /* Silence follow-up errors. */
6171 gfc_new_block->binding_label = NULL;
6172 }
6173 else
6174 {
6175 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6176 s->sym_name = gfc_new_block->name;
6177 s->where = gfc_new_block->declared_at;
6178 s->defined = 1;
6179 s->ns = gfc_current_ns;
6180 }
6181 }
6182
6183 /* Don't add the symbol multiple times. */
6184 if (gfc_new_block->binding_label
6185 && (!gfc_notification_std (GFC_STD_F2008)
6186 || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
6187 {
6188 s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
6189
6190 if (s->defined
6191 || (s->type != GSYM_UNKNOWN
6192 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6193 {
6194 gfc_global_used (s, &gfc_new_block->declared_at);
6195 /* Silence follow-up errors. */
6196 gfc_new_block->binding_label = NULL;
6197 }
6198 else
6199 {
6200 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6201 s->sym_name = gfc_new_block->name;
6202 s->binding_label = gfc_new_block->binding_label;
6203 s->where = gfc_new_block->declared_at;
6204 s->defined = 1;
6205 s->ns = gfc_current_ns;
6206 }
6207 }
6208 }
6209
6210
6211 /* Add a program to the global symbol table. */
6212
6213 static void
add_global_program(void)6214 add_global_program (void)
6215 {
6216 gfc_gsymbol *s;
6217
6218 if (gfc_new_block == NULL)
6219 return;
6220 s = gfc_get_gsymbol (gfc_new_block->name, false);
6221
6222 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
6223 gfc_global_used (s, &gfc_new_block->declared_at);
6224 else
6225 {
6226 s->type = GSYM_PROGRAM;
6227 s->where = gfc_new_block->declared_at;
6228 s->defined = 1;
6229 s->ns = gfc_current_ns;
6230 }
6231 }
6232
6233
6234 /* Resolve all the program units. */
6235 static void
resolve_all_program_units(gfc_namespace * gfc_global_ns_list)6236 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
6237 {
6238 gfc_derived_types = NULL;
6239 gfc_current_ns = gfc_global_ns_list;
6240 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6241 {
6242 if (gfc_current_ns->proc_name
6243 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6244 continue; /* Already resolved. */
6245
6246 if (gfc_current_ns->proc_name)
6247 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6248 gfc_resolve (gfc_current_ns);
6249 gfc_current_ns->derived_types = gfc_derived_types;
6250 gfc_derived_types = NULL;
6251 }
6252 }
6253
6254
6255 static void
clean_up_modules(gfc_gsymbol * gsym)6256 clean_up_modules (gfc_gsymbol *gsym)
6257 {
6258 if (gsym == NULL)
6259 return;
6260
6261 clean_up_modules (gsym->left);
6262 clean_up_modules (gsym->right);
6263
6264 if (gsym->type != GSYM_MODULE || !gsym->ns)
6265 return;
6266
6267 gfc_current_ns = gsym->ns;
6268 gfc_derived_types = gfc_current_ns->derived_types;
6269 gfc_done_2 ();
6270 gsym->ns = NULL;
6271 return;
6272 }
6273
6274
6275 /* Translate all the program units. This could be in a different order
6276 to resolution if there are forward references in the file. */
6277 static void
translate_all_program_units(gfc_namespace * gfc_global_ns_list)6278 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
6279 {
6280 int errors;
6281
6282 gfc_current_ns = gfc_global_ns_list;
6283 gfc_get_errors (NULL, &errors);
6284
6285 /* We first translate all modules to make sure that later parts
6286 of the program can use the decl. Then we translate the nonmodules. */
6287
6288 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6289 {
6290 if (!gfc_current_ns->proc_name
6291 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6292 continue;
6293
6294 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6295 gfc_derived_types = gfc_current_ns->derived_types;
6296 gfc_generate_module_code (gfc_current_ns);
6297 gfc_current_ns->translated = 1;
6298 }
6299
6300 gfc_current_ns = gfc_global_ns_list;
6301 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6302 {
6303 if (gfc_current_ns->proc_name
6304 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6305 continue;
6306
6307 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6308 gfc_derived_types = gfc_current_ns->derived_types;
6309 gfc_generate_code (gfc_current_ns);
6310 gfc_current_ns->translated = 1;
6311 }
6312
6313 /* Clean up all the namespaces after translation. */
6314 gfc_current_ns = gfc_global_ns_list;
6315 for (;gfc_current_ns;)
6316 {
6317 gfc_namespace *ns;
6318
6319 if (gfc_current_ns->proc_name
6320 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6321 {
6322 gfc_current_ns = gfc_current_ns->sibling;
6323 continue;
6324 }
6325
6326 ns = gfc_current_ns->sibling;
6327 gfc_derived_types = gfc_current_ns->derived_types;
6328 gfc_done_2 ();
6329 gfc_current_ns = ns;
6330 }
6331
6332 clean_up_modules (gfc_gsym_root);
6333 }
6334
6335
6336 /* Top level parser. */
6337
6338 bool
gfc_parse_file(void)6339 gfc_parse_file (void)
6340 {
6341 int seen_program, errors_before, errors;
6342 gfc_state_data top, s;
6343 gfc_statement st;
6344 locus prog_locus;
6345 gfc_namespace *next;
6346
6347 gfc_start_source_files ();
6348
6349 top.state = COMP_NONE;
6350 top.sym = NULL;
6351 top.previous = NULL;
6352 top.head = top.tail = NULL;
6353 top.do_variable = NULL;
6354
6355 gfc_state_stack = ⊤
6356
6357 gfc_clear_new_st ();
6358
6359 gfc_statement_label = NULL;
6360
6361 if (setjmp (eof_buf))
6362 return false; /* Come here on unexpected EOF */
6363
6364 /* Prepare the global namespace that will contain the
6365 program units. */
6366 gfc_global_ns_list = next = NULL;
6367
6368 seen_program = 0;
6369 errors_before = 0;
6370
6371 /* Exit early for empty files. */
6372 if (gfc_at_eof ())
6373 goto done;
6374
6375 in_specification_block = true;
6376 loop:
6377 gfc_init_2 ();
6378 st = next_statement ();
6379 switch (st)
6380 {
6381 case ST_NONE:
6382 gfc_done_2 ();
6383 goto done;
6384
6385 case ST_PROGRAM:
6386 if (seen_program)
6387 goto duplicate_main;
6388 seen_program = 1;
6389 prog_locus = gfc_current_locus;
6390
6391 push_state (&s, COMP_PROGRAM, gfc_new_block);
6392 main_program_symbol (gfc_current_ns, gfc_new_block->name);
6393 accept_statement (st);
6394 add_global_program ();
6395 parse_progunit (ST_NONE);
6396 goto prog_units;
6397
6398 case ST_SUBROUTINE:
6399 add_global_procedure (true);
6400 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
6401 accept_statement (st);
6402 parse_progunit (ST_NONE);
6403 goto prog_units;
6404
6405 case ST_FUNCTION:
6406 add_global_procedure (false);
6407 push_state (&s, COMP_FUNCTION, gfc_new_block);
6408 accept_statement (st);
6409 parse_progunit (ST_NONE);
6410 goto prog_units;
6411
6412 case ST_BLOCK_DATA:
6413 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
6414 accept_statement (st);
6415 parse_block_data ();
6416 break;
6417
6418 case ST_MODULE:
6419 push_state (&s, COMP_MODULE, gfc_new_block);
6420 accept_statement (st);
6421
6422 gfc_get_errors (NULL, &errors_before);
6423 parse_module ();
6424 break;
6425
6426 case ST_SUBMODULE:
6427 push_state (&s, COMP_SUBMODULE, gfc_new_block);
6428 accept_statement (st);
6429
6430 gfc_get_errors (NULL, &errors_before);
6431 parse_module ();
6432 break;
6433
6434 /* Anything else starts a nameless main program block. */
6435 default:
6436 if (seen_program)
6437 goto duplicate_main;
6438 seen_program = 1;
6439 prog_locus = gfc_current_locus;
6440
6441 push_state (&s, COMP_PROGRAM, gfc_new_block);
6442 main_program_symbol (gfc_current_ns, "MAIN__");
6443 parse_progunit (st);
6444 goto prog_units;
6445 }
6446
6447 /* Handle the non-program units. */
6448 gfc_current_ns->code = s.head;
6449
6450 gfc_resolve (gfc_current_ns);
6451
6452 /* Fix the implicit_pure attribute for those procedures who should
6453 not have it. */
6454 while (gfc_fix_implicit_pure (gfc_current_ns))
6455 ;
6456
6457 /* Dump the parse tree if requested. */
6458 if (flag_dump_fortran_original)
6459 gfc_dump_parse_tree (gfc_current_ns, stdout);
6460
6461 gfc_get_errors (NULL, &errors);
6462 if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
6463 {
6464 gfc_dump_module (s.sym->name, errors_before == errors);
6465 gfc_current_ns->derived_types = gfc_derived_types;
6466 gfc_derived_types = NULL;
6467 goto prog_units;
6468 }
6469 else
6470 {
6471 if (errors == 0)
6472 gfc_generate_code (gfc_current_ns);
6473 pop_state ();
6474 gfc_done_2 ();
6475 }
6476
6477 goto loop;
6478
6479 prog_units:
6480 /* The main program and non-contained procedures are put
6481 in the global namespace list, so that they can be processed
6482 later and all their interfaces resolved. */
6483 gfc_current_ns->code = s.head;
6484 if (next)
6485 {
6486 for (; next->sibling; next = next->sibling)
6487 ;
6488 next->sibling = gfc_current_ns;
6489 }
6490 else
6491 gfc_global_ns_list = gfc_current_ns;
6492
6493 next = gfc_current_ns;
6494
6495 pop_state ();
6496 goto loop;
6497
6498 done:
6499 /* Do the resolution. */
6500 resolve_all_program_units (gfc_global_ns_list);
6501
6502 /* Go through all top-level namespaces and unset the implicit_pure
6503 attribute for any procedures that call something not pure or
6504 implicit_pure. Because the a procedure marked as not implicit_pure
6505 in one sweep may be called by another routine, we repeat this
6506 process until there are no more changes. */
6507 bool changed;
6508 do
6509 {
6510 changed = false;
6511 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6512 gfc_current_ns = gfc_current_ns->sibling)
6513 {
6514 if (gfc_fix_implicit_pure (gfc_current_ns))
6515 changed = true;
6516 }
6517 }
6518 while (changed);
6519
6520 /* Fixup for external procedures. */
6521 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6522 gfc_current_ns = gfc_current_ns->sibling)
6523 gfc_check_externals (gfc_current_ns);
6524
6525 /* Do the parse tree dump. */
6526 gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
6527
6528 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6529 if (!gfc_current_ns->proc_name
6530 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6531 {
6532 gfc_dump_parse_tree (gfc_current_ns, stdout);
6533 fputs ("------------------------------------------\n\n", stdout);
6534 }
6535
6536 /* Dump C prototypes. */
6537 if (flag_c_prototypes || flag_c_prototypes_external)
6538 {
6539 fprintf (stdout,
6540 "#include <stddef.h>\n"
6541 "#ifdef __cplusplus\n"
6542 "#include <complex>\n"
6543 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6544 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6545 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6546 "extern \"C\" {\n"
6547 "#else\n"
6548 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6549 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6550 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6551 "#endif\n\n");
6552 }
6553
6554 /* First dump BIND(C) prototypes. */
6555 if (flag_c_prototypes)
6556 {
6557 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6558 gfc_current_ns = gfc_current_ns->sibling)
6559 gfc_dump_c_prototypes (gfc_current_ns, stdout);
6560 }
6561
6562 /* Dump external prototypes. */
6563 if (flag_c_prototypes_external)
6564 gfc_dump_external_c_prototypes (stdout);
6565
6566 if (flag_c_prototypes || flag_c_prototypes_external)
6567 fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
6568
6569 /* Do the translation. */
6570 translate_all_program_units (gfc_global_ns_list);
6571
6572 /* Dump the global symbol ist. We only do this here because part
6573 of it is generated after mangling the identifiers in
6574 trans-decl.c. */
6575
6576 if (flag_dump_fortran_global)
6577 gfc_dump_global_symbols (stdout);
6578
6579 gfc_end_source_files ();
6580 return true;
6581
6582 duplicate_main:
6583 /* If we see a duplicate main program, shut down. If the second
6584 instance is an implied main program, i.e. data decls or executable
6585 statements, we're in for lots of errors. */
6586 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
6587 reject_statement ();
6588 gfc_done_2 ();
6589 return true;
6590 }
6591
6592 /* Return true if this state data represents an OpenACC region. */
6593 bool
is_oacc(gfc_state_data * sd)6594 is_oacc (gfc_state_data *sd)
6595 {
6596 switch (sd->construct->op)
6597 {
6598 case EXEC_OACC_PARALLEL_LOOP:
6599 case EXEC_OACC_PARALLEL:
6600 case EXEC_OACC_KERNELS_LOOP:
6601 case EXEC_OACC_KERNELS:
6602 case EXEC_OACC_SERIAL_LOOP:
6603 case EXEC_OACC_SERIAL:
6604 case EXEC_OACC_DATA:
6605 case EXEC_OACC_HOST_DATA:
6606 case EXEC_OACC_LOOP:
6607 case EXEC_OACC_UPDATE:
6608 case EXEC_OACC_WAIT:
6609 case EXEC_OACC_CACHE:
6610 case EXEC_OACC_ENTER_DATA:
6611 case EXEC_OACC_EXIT_DATA:
6612 case EXEC_OACC_ATOMIC:
6613 case EXEC_OACC_ROUTINE:
6614 return true;
6615
6616 default:
6617 return false;
6618 }
6619 }
6620