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 bool
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)
3713 return true;
3714
3715 ts = gfc_current_ns->proc_name->result->ts;
3716
3717 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3718 /* TODO: Extend when KIND type parameters are implemented. */
3719 if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
3720 {
3721 /* Reject invalid type of specification expression for length. */
3722 if (ts.u.cl->length->ts.type != BT_INTEGER)
3723 return false;
3724
3725 gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
3726 }
3727
3728 return true;
3729 }
3730
3731
3732 /* Parse a set of specification statements. Returns the statement
3733 that doesn't fit. */
3734
3735 static gfc_statement
parse_spec(gfc_statement st)3736 parse_spec (gfc_statement st)
3737 {
3738 st_state ss;
3739 bool function_result_typed = false;
3740 bool bad_characteristic = false;
3741 gfc_typespec *ts;
3742
3743 in_specification_block = true;
3744
3745 verify_st_order (&ss, ST_NONE, false);
3746 if (st == ST_NONE)
3747 st = next_statement ();
3748
3749 /* If we are not inside a function or don't have a result specified so far,
3750 do nothing special about it. */
3751 if (gfc_current_state () != COMP_FUNCTION)
3752 function_result_typed = true;
3753 else
3754 {
3755 gfc_symbol* proc = gfc_current_ns->proc_name;
3756 gcc_assert (proc);
3757
3758 if (proc->result->ts.type == BT_UNKNOWN)
3759 function_result_typed = true;
3760 }
3761
3762 loop:
3763
3764 /* If we're inside a BLOCK construct, some statements are disallowed.
3765 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3766 or VALUE are also disallowed, but they don't have a particular ST_*
3767 key so we have to check for them individually in their matcher routine. */
3768 if (gfc_current_state () == COMP_BLOCK)
3769 switch (st)
3770 {
3771 case ST_IMPLICIT:
3772 case ST_IMPLICIT_NONE:
3773 case ST_NAMELIST:
3774 case ST_COMMON:
3775 case ST_EQUIVALENCE:
3776 case ST_STATEMENT_FUNCTION:
3777 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3778 gfc_ascii_statement (st));
3779 reject_statement ();
3780 break;
3781
3782 default:
3783 break;
3784 }
3785 else if (gfc_current_state () == COMP_BLOCK_DATA)
3786 /* Fortran 2008, C1116. */
3787 switch (st)
3788 {
3789 case ST_ATTR_DECL:
3790 case ST_COMMON:
3791 case ST_DATA:
3792 case ST_DATA_DECL:
3793 case ST_DERIVED_DECL:
3794 case ST_END_BLOCK_DATA:
3795 case ST_EQUIVALENCE:
3796 case ST_IMPLICIT:
3797 case ST_IMPLICIT_NONE:
3798 case ST_OMP_THREADPRIVATE:
3799 case ST_PARAMETER:
3800 case ST_STRUCTURE_DECL:
3801 case ST_TYPE:
3802 case ST_USE:
3803 break;
3804
3805 case ST_NONE:
3806 break;
3807
3808 default:
3809 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3810 gfc_ascii_statement (st));
3811 reject_statement ();
3812 break;
3813 }
3814
3815 /* If we find a statement that cannot be followed by an IMPLICIT statement
3816 (and thus we can expect to see none any further), type the function result
3817 if it has not yet been typed. Be careful not to give the END statement
3818 to verify_st_order! */
3819 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
3820 {
3821 bool verify_now = false;
3822
3823 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
3824 verify_now = true;
3825 else
3826 {
3827 st_state dummyss;
3828 verify_st_order (&dummyss, ST_NONE, false);
3829 verify_st_order (&dummyss, st, false);
3830
3831 if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
3832 verify_now = true;
3833 }
3834
3835 if (verify_now)
3836 function_result_typed = check_function_result_typed ();
3837 }
3838
3839 switch (st)
3840 {
3841 case ST_NONE:
3842 unexpected_eof ();
3843
3844 case ST_IMPLICIT_NONE:
3845 case ST_IMPLICIT:
3846 if (!function_result_typed)
3847 function_result_typed = check_function_result_typed ();
3848 goto declSt;
3849
3850 case ST_FORMAT:
3851 case ST_ENTRY:
3852 case ST_DATA: /* Not allowed in interfaces */
3853 if (gfc_current_state () == COMP_INTERFACE)
3854 break;
3855
3856 /* Fall through */
3857
3858 case ST_USE:
3859 case ST_IMPORT:
3860 case ST_PARAMETER:
3861 case ST_PUBLIC:
3862 case ST_PRIVATE:
3863 case ST_STRUCTURE_DECL:
3864 case ST_DERIVED_DECL:
3865 case_decl:
3866 case_omp_decl:
3867 declSt:
3868 if (!verify_st_order (&ss, st, false))
3869 {
3870 reject_statement ();
3871 st = next_statement ();
3872 goto loop;
3873 }
3874
3875 switch (st)
3876 {
3877 case ST_INTERFACE:
3878 parse_interface ();
3879 break;
3880
3881 case ST_STRUCTURE_DECL:
3882 parse_struct_map (ST_STRUCTURE_DECL);
3883 break;
3884
3885 case ST_DERIVED_DECL:
3886 parse_derived ();
3887 break;
3888
3889 case ST_PUBLIC:
3890 case ST_PRIVATE:
3891 if (gfc_current_state () != COMP_MODULE)
3892 {
3893 gfc_error ("%s statement must appear in a MODULE",
3894 gfc_ascii_statement (st));
3895 reject_statement ();
3896 break;
3897 }
3898
3899 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
3900 {
3901 gfc_error ("%s statement at %C follows another accessibility "
3902 "specification", gfc_ascii_statement (st));
3903 reject_statement ();
3904 break;
3905 }
3906
3907 gfc_current_ns->default_access = (st == ST_PUBLIC)
3908 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3909
3910 break;
3911
3912 case ST_STATEMENT_FUNCTION:
3913 if (gfc_current_state () == COMP_MODULE
3914 || gfc_current_state () == COMP_SUBMODULE)
3915 {
3916 unexpected_statement (st);
3917 break;
3918 }
3919
3920 default:
3921 break;
3922 }
3923
3924 accept_statement (st);
3925 st = next_statement ();
3926 goto loop;
3927
3928 case ST_ENUM:
3929 accept_statement (st);
3930 parse_enum();
3931 st = next_statement ();
3932 goto loop;
3933
3934 case ST_GET_FCN_CHARACTERISTICS:
3935 /* This statement triggers the association of a function's result
3936 characteristics. */
3937 ts = &gfc_current_block ()->result->ts;
3938 if (match_deferred_characteristics (ts) != MATCH_YES)
3939 bad_characteristic = true;
3940
3941 st = next_statement ();
3942 goto loop;
3943
3944 default:
3945 break;
3946 }
3947
3948 /* If match_deferred_characteristics failed, then there is an error. */
3949 if (bad_characteristic)
3950 {
3951 ts = &gfc_current_block ()->result->ts;
3952 if (ts->type != BT_DERIVED)
3953 gfc_error ("Bad kind expression for function %qs at %L",
3954 gfc_current_block ()->name,
3955 &gfc_current_block ()->declared_at);
3956 else
3957 gfc_error ("The type for function %qs at %L is not accessible",
3958 gfc_current_block ()->name,
3959 &gfc_current_block ()->declared_at);
3960
3961 gfc_current_block ()->ts.kind = 0;
3962 /* Keep the derived type; if it's bad, it will be discovered later. */
3963 if (!(ts->type == BT_DERIVED && ts->u.derived))
3964 ts->type = BT_UNKNOWN;
3965 }
3966
3967 in_specification_block = false;
3968
3969 return st;
3970 }
3971
3972
3973 /* Parse a WHERE block, (not a simple WHERE statement). */
3974
3975 static void
parse_where_block(void)3976 parse_where_block (void)
3977 {
3978 int seen_empty_else;
3979 gfc_code *top, *d;
3980 gfc_state_data s;
3981 gfc_statement st;
3982
3983 accept_statement (ST_WHERE_BLOCK);
3984 top = gfc_state_stack->tail;
3985
3986 push_state (&s, COMP_WHERE, gfc_new_block);
3987
3988 d = add_statement ();
3989 d->expr1 = top->expr1;
3990 d->op = EXEC_WHERE;
3991
3992 top->expr1 = NULL;
3993 top->block = d;
3994
3995 seen_empty_else = 0;
3996
3997 do
3998 {
3999 st = next_statement ();
4000 switch (st)
4001 {
4002 case ST_NONE:
4003 unexpected_eof ();
4004
4005 case ST_WHERE_BLOCK:
4006 parse_where_block ();
4007 break;
4008
4009 case ST_ASSIGNMENT:
4010 case ST_WHERE:
4011 accept_statement (st);
4012 break;
4013
4014 case ST_ELSEWHERE:
4015 if (seen_empty_else)
4016 {
4017 gfc_error ("ELSEWHERE statement at %C follows previous "
4018 "unmasked ELSEWHERE");
4019 reject_statement ();
4020 break;
4021 }
4022
4023 if (new_st.expr1 == NULL)
4024 seen_empty_else = 1;
4025
4026 d = new_level (gfc_state_stack->head);
4027 d->op = EXEC_WHERE;
4028 d->expr1 = new_st.expr1;
4029
4030 accept_statement (st);
4031
4032 break;
4033
4034 case ST_END_WHERE:
4035 accept_statement (st);
4036 break;
4037
4038 default:
4039 gfc_error ("Unexpected %s statement in WHERE block at %C",
4040 gfc_ascii_statement (st));
4041 reject_statement ();
4042 break;
4043 }
4044 }
4045 while (st != ST_END_WHERE);
4046
4047 pop_state ();
4048 }
4049
4050
4051 /* Parse a FORALL block (not a simple FORALL statement). */
4052
4053 static void
parse_forall_block(void)4054 parse_forall_block (void)
4055 {
4056 gfc_code *top, *d;
4057 gfc_state_data s;
4058 gfc_statement st;
4059
4060 accept_statement (ST_FORALL_BLOCK);
4061 top = gfc_state_stack->tail;
4062
4063 push_state (&s, COMP_FORALL, gfc_new_block);
4064
4065 d = add_statement ();
4066 d->op = EXEC_FORALL;
4067 top->block = d;
4068
4069 do
4070 {
4071 st = next_statement ();
4072 switch (st)
4073 {
4074
4075 case ST_ASSIGNMENT:
4076 case ST_POINTER_ASSIGNMENT:
4077 case ST_WHERE:
4078 case ST_FORALL:
4079 accept_statement (st);
4080 break;
4081
4082 case ST_WHERE_BLOCK:
4083 parse_where_block ();
4084 break;
4085
4086 case ST_FORALL_BLOCK:
4087 parse_forall_block ();
4088 break;
4089
4090 case ST_END_FORALL:
4091 accept_statement (st);
4092 break;
4093
4094 case ST_NONE:
4095 unexpected_eof ();
4096
4097 default:
4098 gfc_error ("Unexpected %s statement in FORALL block at %C",
4099 gfc_ascii_statement (st));
4100
4101 reject_statement ();
4102 break;
4103 }
4104 }
4105 while (st != ST_END_FORALL);
4106
4107 pop_state ();
4108 }
4109
4110
4111 static gfc_statement parse_executable (gfc_statement);
4112
4113 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4114
4115 static void
parse_if_block(void)4116 parse_if_block (void)
4117 {
4118 gfc_code *top, *d;
4119 gfc_statement st;
4120 locus else_locus;
4121 gfc_state_data s;
4122 int seen_else;
4123
4124 seen_else = 0;
4125 accept_statement (ST_IF_BLOCK);
4126
4127 top = gfc_state_stack->tail;
4128 push_state (&s, COMP_IF, gfc_new_block);
4129
4130 new_st.op = EXEC_IF;
4131 d = add_statement ();
4132
4133 d->expr1 = top->expr1;
4134 top->expr1 = NULL;
4135 top->block = d;
4136
4137 do
4138 {
4139 st = parse_executable (ST_NONE);
4140
4141 switch (st)
4142 {
4143 case ST_NONE:
4144 unexpected_eof ();
4145
4146 case ST_ELSEIF:
4147 if (seen_else)
4148 {
4149 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4150 "statement at %L", &else_locus);
4151
4152 reject_statement ();
4153 break;
4154 }
4155
4156 d = new_level (gfc_state_stack->head);
4157 d->op = EXEC_IF;
4158 d->expr1 = new_st.expr1;
4159
4160 accept_statement (st);
4161
4162 break;
4163
4164 case ST_ELSE:
4165 if (seen_else)
4166 {
4167 gfc_error ("Duplicate ELSE statements at %L and %C",
4168 &else_locus);
4169 reject_statement ();
4170 break;
4171 }
4172
4173 seen_else = 1;
4174 else_locus = gfc_current_locus;
4175
4176 d = new_level (gfc_state_stack->head);
4177 d->op = EXEC_IF;
4178
4179 accept_statement (st);
4180
4181 break;
4182
4183 case ST_ENDIF:
4184 break;
4185
4186 default:
4187 unexpected_statement (st);
4188 break;
4189 }
4190 }
4191 while (st != ST_ENDIF);
4192
4193 pop_state ();
4194 accept_statement (st);
4195 }
4196
4197
4198 /* Parse a SELECT block. */
4199
4200 static void
parse_select_block(void)4201 parse_select_block (void)
4202 {
4203 gfc_statement st;
4204 gfc_code *cp;
4205 gfc_state_data s;
4206
4207 accept_statement (ST_SELECT_CASE);
4208
4209 cp = gfc_state_stack->tail;
4210 push_state (&s, COMP_SELECT, gfc_new_block);
4211
4212 /* Make sure that the next statement is a CASE or END SELECT. */
4213 for (;;)
4214 {
4215 st = next_statement ();
4216 if (st == ST_NONE)
4217 unexpected_eof ();
4218 if (st == ST_END_SELECT)
4219 {
4220 /* Empty SELECT CASE is OK. */
4221 accept_statement (st);
4222 pop_state ();
4223 return;
4224 }
4225 if (st == ST_CASE)
4226 break;
4227
4228 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4229 "CASE at %C");
4230
4231 reject_statement ();
4232 }
4233
4234 /* At this point, we've got a nonempty select block. */
4235 cp = new_level (cp);
4236 *cp = new_st;
4237
4238 accept_statement (st);
4239
4240 do
4241 {
4242 st = parse_executable (ST_NONE);
4243 switch (st)
4244 {
4245 case ST_NONE:
4246 unexpected_eof ();
4247
4248 case ST_CASE:
4249 cp = new_level (gfc_state_stack->head);
4250 *cp = new_st;
4251 gfc_clear_new_st ();
4252
4253 accept_statement (st);
4254 /* Fall through */
4255
4256 case ST_END_SELECT:
4257 break;
4258
4259 /* Can't have an executable statement because of
4260 parse_executable(). */
4261 default:
4262 unexpected_statement (st);
4263 break;
4264 }
4265 }
4266 while (st != ST_END_SELECT);
4267
4268 pop_state ();
4269 accept_statement (st);
4270 }
4271
4272
4273 /* Pop the current selector from the SELECT TYPE stack. */
4274
4275 static void
select_type_pop(void)4276 select_type_pop (void)
4277 {
4278 gfc_select_type_stack *old = select_type_stack;
4279 select_type_stack = old->prev;
4280 free (old);
4281 }
4282
4283
4284 /* Parse a SELECT TYPE construct (F03:R821). */
4285
4286 static void
parse_select_type_block(void)4287 parse_select_type_block (void)
4288 {
4289 gfc_statement st;
4290 gfc_code *cp;
4291 gfc_state_data s;
4292
4293 gfc_current_ns = new_st.ext.block.ns;
4294 accept_statement (ST_SELECT_TYPE);
4295
4296 cp = gfc_state_stack->tail;
4297 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
4298
4299 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4300 or END SELECT. */
4301 for (;;)
4302 {
4303 st = next_statement ();
4304 if (st == ST_NONE)
4305 unexpected_eof ();
4306 if (st == ST_END_SELECT)
4307 /* Empty SELECT CASE is OK. */
4308 goto done;
4309 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
4310 break;
4311
4312 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4313 "following SELECT TYPE at %C");
4314
4315 reject_statement ();
4316 }
4317
4318 /* At this point, we've got a nonempty select block. */
4319 cp = new_level (cp);
4320 *cp = new_st;
4321
4322 accept_statement (st);
4323
4324 do
4325 {
4326 st = parse_executable (ST_NONE);
4327 switch (st)
4328 {
4329 case ST_NONE:
4330 unexpected_eof ();
4331
4332 case ST_TYPE_IS:
4333 case ST_CLASS_IS:
4334 cp = new_level (gfc_state_stack->head);
4335 *cp = new_st;
4336 gfc_clear_new_st ();
4337
4338 accept_statement (st);
4339 /* Fall through */
4340
4341 case ST_END_SELECT:
4342 break;
4343
4344 /* Can't have an executable statement because of
4345 parse_executable(). */
4346 default:
4347 unexpected_statement (st);
4348 break;
4349 }
4350 }
4351 while (st != ST_END_SELECT);
4352
4353 done:
4354 pop_state ();
4355 accept_statement (st);
4356 gfc_current_ns = gfc_current_ns->parent;
4357 select_type_pop ();
4358 }
4359
4360
4361 /* Parse a SELECT RANK construct. */
4362
4363 static void
parse_select_rank_block(void)4364 parse_select_rank_block (void)
4365 {
4366 gfc_statement st;
4367 gfc_code *cp;
4368 gfc_state_data s;
4369
4370 gfc_current_ns = new_st.ext.block.ns;
4371 accept_statement (ST_SELECT_RANK);
4372
4373 cp = gfc_state_stack->tail;
4374 push_state (&s, COMP_SELECT_RANK, gfc_new_block);
4375
4376 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4377 for (;;)
4378 {
4379 st = next_statement ();
4380 if (st == ST_NONE)
4381 unexpected_eof ();
4382 if (st == ST_END_SELECT)
4383 /* Empty SELECT CASE is OK. */
4384 goto done;
4385 if (st == ST_RANK)
4386 break;
4387
4388 gfc_error ("Expected RANK or RANK DEFAULT "
4389 "following SELECT RANK at %C");
4390
4391 reject_statement ();
4392 }
4393
4394 /* At this point, we've got a nonempty select block. */
4395 cp = new_level (cp);
4396 *cp = new_st;
4397
4398 accept_statement (st);
4399
4400 do
4401 {
4402 st = parse_executable (ST_NONE);
4403 switch (st)
4404 {
4405 case ST_NONE:
4406 unexpected_eof ();
4407
4408 case ST_RANK:
4409 cp = new_level (gfc_state_stack->head);
4410 *cp = new_st;
4411 gfc_clear_new_st ();
4412
4413 accept_statement (st);
4414 /* Fall through */
4415
4416 case ST_END_SELECT:
4417 break;
4418
4419 /* Can't have an executable statement because of
4420 parse_executable(). */
4421 default:
4422 unexpected_statement (st);
4423 break;
4424 }
4425 }
4426 while (st != ST_END_SELECT);
4427
4428 done:
4429 pop_state ();
4430 accept_statement (st);
4431 gfc_current_ns = gfc_current_ns->parent;
4432 select_type_pop ();
4433 }
4434
4435
4436 /* Given a symbol, make sure it is not an iteration variable for a DO
4437 statement. This subroutine is called when the symbol is seen in a
4438 context that causes it to become redefined. If the symbol is an
4439 iterator, we generate an error message and return nonzero. */
4440
4441 int
gfc_check_do_variable(gfc_symtree * st)4442 gfc_check_do_variable (gfc_symtree *st)
4443 {
4444 gfc_state_data *s;
4445
4446 if (!st)
4447 return 0;
4448
4449 for (s=gfc_state_stack; s; s = s->previous)
4450 if (s->do_variable == st)
4451 {
4452 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4453 "loop beginning at %L", st->name, &s->head->loc);
4454 return 1;
4455 }
4456
4457 return 0;
4458 }
4459
4460
4461 /* Checks to see if the current statement label closes an enddo.
4462 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4463 an error) if it incorrectly closes an ENDDO. */
4464
4465 static int
check_do_closure(void)4466 check_do_closure (void)
4467 {
4468 gfc_state_data *p;
4469
4470 if (gfc_statement_label == NULL)
4471 return 0;
4472
4473 for (p = gfc_state_stack; p; p = p->previous)
4474 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4475 break;
4476
4477 if (p == NULL)
4478 return 0; /* No loops to close */
4479
4480 if (p->ext.end_do_label == gfc_statement_label)
4481 {
4482 if (p == gfc_state_stack)
4483 return 1;
4484
4485 gfc_error ("End of nonblock DO statement at %C is within another block");
4486 return 2;
4487 }
4488
4489 /* At this point, the label doesn't terminate the innermost loop.
4490 Make sure it doesn't terminate another one. */
4491 for (; p; p = p->previous)
4492 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4493 && p->ext.end_do_label == gfc_statement_label)
4494 {
4495 gfc_error ("End of nonblock DO statement at %C is interwoven "
4496 "with another DO loop");
4497 return 2;
4498 }
4499
4500 return 0;
4501 }
4502
4503
4504 /* Parse a series of contained program units. */
4505
4506 static void parse_progunit (gfc_statement);
4507
4508
4509 /* Parse a CRITICAL block. */
4510
4511 static void
parse_critical_block(void)4512 parse_critical_block (void)
4513 {
4514 gfc_code *top, *d;
4515 gfc_state_data s, *sd;
4516 gfc_statement st;
4517
4518 for (sd = gfc_state_stack; sd; sd = sd->previous)
4519 if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
4520 gfc_error_now (is_oacc (sd)
4521 ? G_("CRITICAL block inside of OpenACC region at %C")
4522 : G_("CRITICAL block inside of OpenMP region at %C"));
4523
4524 s.ext.end_do_label = new_st.label1;
4525
4526 accept_statement (ST_CRITICAL);
4527 top = gfc_state_stack->tail;
4528
4529 push_state (&s, COMP_CRITICAL, gfc_new_block);
4530
4531 d = add_statement ();
4532 d->op = EXEC_CRITICAL;
4533 top->block = d;
4534
4535 do
4536 {
4537 st = parse_executable (ST_NONE);
4538
4539 switch (st)
4540 {
4541 case ST_NONE:
4542 unexpected_eof ();
4543 break;
4544
4545 case ST_END_CRITICAL:
4546 if (s.ext.end_do_label != NULL
4547 && s.ext.end_do_label != gfc_statement_label)
4548 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4549 "match CRITICAL label");
4550
4551 if (gfc_statement_label != NULL)
4552 {
4553 new_st.op = EXEC_NOP;
4554 add_statement ();
4555 }
4556 break;
4557
4558 default:
4559 unexpected_statement (st);
4560 break;
4561 }
4562 }
4563 while (st != ST_END_CRITICAL);
4564
4565 pop_state ();
4566 accept_statement (st);
4567 }
4568
4569
4570 /* Set up the local namespace for a BLOCK construct. */
4571
4572 gfc_namespace*
gfc_build_block_ns(gfc_namespace * parent_ns)4573 gfc_build_block_ns (gfc_namespace *parent_ns)
4574 {
4575 gfc_namespace* my_ns;
4576 static int numblock = 1;
4577
4578 my_ns = gfc_get_namespace (parent_ns, 1);
4579 my_ns->construct_entities = 1;
4580
4581 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4582 code generation (so it must not be NULL).
4583 We set its recursive argument if our container procedure is recursive, so
4584 that local variables are accordingly placed on the stack when it
4585 will be necessary. */
4586 if (gfc_new_block)
4587 my_ns->proc_name = gfc_new_block;
4588 else
4589 {
4590 bool t;
4591 char buffer[20]; /* Enough to hold "block@2147483648\n". */
4592
4593 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
4594 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
4595 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
4596 my_ns->proc_name->name, NULL);
4597 gcc_assert (t);
4598 gfc_commit_symbol (my_ns->proc_name);
4599 }
4600
4601 if (parent_ns->proc_name)
4602 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
4603
4604 return my_ns;
4605 }
4606
4607
4608 /* Parse a BLOCK construct. */
4609
4610 static void
parse_block_construct(void)4611 parse_block_construct (void)
4612 {
4613 gfc_namespace* my_ns;
4614 gfc_namespace* my_parent;
4615 gfc_state_data s;
4616
4617 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
4618
4619 my_ns = gfc_build_block_ns (gfc_current_ns);
4620
4621 new_st.op = EXEC_BLOCK;
4622 new_st.ext.block.ns = my_ns;
4623 new_st.ext.block.assoc = NULL;
4624 accept_statement (ST_BLOCK);
4625
4626 push_state (&s, COMP_BLOCK, my_ns->proc_name);
4627 gfc_current_ns = my_ns;
4628 my_parent = my_ns->parent;
4629
4630 parse_progunit (ST_NONE);
4631
4632 /* Don't depend on the value of gfc_current_ns; it might have been
4633 reset if the block had errors and was cleaned up. */
4634 gfc_current_ns = my_parent;
4635
4636 pop_state ();
4637 }
4638
4639
4640 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4641 behind the scenes with compiler-generated variables. */
4642
4643 static void
parse_associate(void)4644 parse_associate (void)
4645 {
4646 gfc_namespace* my_ns;
4647 gfc_state_data s;
4648 gfc_statement st;
4649 gfc_association_list* a;
4650
4651 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
4652
4653 my_ns = gfc_build_block_ns (gfc_current_ns);
4654
4655 new_st.op = EXEC_BLOCK;
4656 new_st.ext.block.ns = my_ns;
4657 gcc_assert (new_st.ext.block.assoc);
4658
4659 /* Add all associate-names as BLOCK variables. Creating them is enough
4660 for now, they'll get their values during trans-* phase. */
4661 gfc_current_ns = my_ns;
4662 for (a = new_st.ext.block.assoc; a; a = a->next)
4663 {
4664 gfc_symbol* sym;
4665 gfc_ref *ref;
4666 gfc_array_ref *array_ref;
4667
4668 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
4669 gcc_unreachable ();
4670
4671 sym = a->st->n.sym;
4672 sym->attr.flavor = FL_VARIABLE;
4673 sym->assoc = a;
4674 sym->declared_at = a->where;
4675 gfc_set_sym_referenced (sym);
4676
4677 /* Initialize the typespec. It is not available in all cases,
4678 however, as it may only be set on the target during resolution.
4679 Still, sometimes it helps to have it right now -- especially
4680 for parsing component references on the associate-name
4681 in case of association to a derived-type. */
4682 sym->ts = a->target->ts;
4683
4684 /* Don’t share the character length information between associate
4685 variable and target if the length is not a compile-time constant,
4686 as we don’t want to touch some other character length variable when
4687 we try to initialize the associate variable’s character length
4688 variable.
4689 We do it here rather than later so that expressions referencing the
4690 associate variable will automatically have the correctly setup length
4691 information. If we did it at resolution stage the expressions would
4692 use the original length information, and the variable a new different
4693 one, but only the latter one would be correctly initialized at
4694 translation stage, and the former one would need some additional setup
4695 there. */
4696 if (sym->ts.type == BT_CHARACTER
4697 && sym->ts.u.cl
4698 && !(sym->ts.u.cl->length
4699 && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
4700 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4701
4702 /* Check if the target expression is array valued. This cannot always
4703 be done by looking at target.rank, because that might not have been
4704 set yet. Therefore traverse the chain of refs, looking for the last
4705 array ref and evaluate that. */
4706 array_ref = NULL;
4707 for (ref = a->target->ref; ref; ref = ref->next)
4708 if (ref->type == REF_ARRAY)
4709 array_ref = &ref->u.ar;
4710 if (array_ref || a->target->rank)
4711 {
4712 gfc_array_spec *as;
4713 int dim, rank = 0;
4714 if (array_ref)
4715 {
4716 a->rankguessed = 1;
4717 /* Count the dimension, that have a non-scalar extend. */
4718 for (dim = 0; dim < array_ref->dimen; ++dim)
4719 if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
4720 && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
4721 && array_ref->end[dim] == NULL
4722 && array_ref->start[dim] != NULL))
4723 ++rank;
4724 }
4725 else
4726 rank = a->target->rank;
4727 /* When the rank is greater than zero then sym will be an array. */
4728 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
4729 {
4730 if ((!CLASS_DATA (sym)->as && rank != 0)
4731 || (CLASS_DATA (sym)->as
4732 && CLASS_DATA (sym)->as->rank != rank))
4733 {
4734 /* Don't just (re-)set the attr and as in the sym.ts,
4735 because this modifies the target's attr and as. Copy the
4736 data and do a build_class_symbol. */
4737 symbol_attribute attr = CLASS_DATA (a->target)->attr;
4738 int corank = gfc_get_corank (a->target);
4739 gfc_typespec type;
4740
4741 if (rank || corank)
4742 {
4743 as = gfc_get_array_spec ();
4744 as->type = AS_DEFERRED;
4745 as->rank = rank;
4746 as->corank = corank;
4747 attr.dimension = rank ? 1 : 0;
4748 attr.codimension = corank ? 1 : 0;
4749 }
4750 else
4751 {
4752 as = NULL;
4753 attr.dimension = attr.codimension = 0;
4754 }
4755 attr.class_ok = 0;
4756 type = CLASS_DATA (sym)->ts;
4757 if (!gfc_build_class_symbol (&type,
4758 &attr, &as))
4759 gcc_unreachable ();
4760 sym->ts = type;
4761 sym->ts.type = BT_CLASS;
4762 sym->attr.class_ok = 1;
4763 }
4764 else
4765 sym->attr.class_ok = 1;
4766 }
4767 else if ((!sym->as && rank != 0)
4768 || (sym->as && sym->as->rank != rank))
4769 {
4770 as = gfc_get_array_spec ();
4771 as->type = AS_DEFERRED;
4772 as->rank = rank;
4773 as->corank = gfc_get_corank (a->target);
4774 sym->as = as;
4775 sym->attr.dimension = 1;
4776 if (as->corank)
4777 sym->attr.codimension = 1;
4778 }
4779 }
4780 }
4781
4782 accept_statement (ST_ASSOCIATE);
4783 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
4784
4785 loop:
4786 st = parse_executable (ST_NONE);
4787 switch (st)
4788 {
4789 case ST_NONE:
4790 unexpected_eof ();
4791
4792 case_end:
4793 accept_statement (st);
4794 my_ns->code = gfc_state_stack->head;
4795 break;
4796
4797 default:
4798 unexpected_statement (st);
4799 goto loop;
4800 }
4801
4802 gfc_current_ns = gfc_current_ns->parent;
4803 pop_state ();
4804 }
4805
4806
4807 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4808 handled inside of parse_executable(), because they aren't really
4809 loop statements. */
4810
4811 static void
parse_do_block(void)4812 parse_do_block (void)
4813 {
4814 gfc_statement st;
4815 gfc_code *top;
4816 gfc_state_data s;
4817 gfc_symtree *stree;
4818 gfc_exec_op do_op;
4819
4820 do_op = new_st.op;
4821 s.ext.end_do_label = new_st.label1;
4822
4823 if (new_st.ext.iterator != NULL)
4824 {
4825 stree = new_st.ext.iterator->var->symtree;
4826 if (directive_unroll != -1)
4827 {
4828 new_st.ext.iterator->unroll = directive_unroll;
4829 directive_unroll = -1;
4830 }
4831 if (directive_ivdep)
4832 {
4833 new_st.ext.iterator->ivdep = directive_ivdep;
4834 directive_ivdep = false;
4835 }
4836 if (directive_vector)
4837 {
4838 new_st.ext.iterator->vector = directive_vector;
4839 directive_vector = false;
4840 }
4841 if (directive_novector)
4842 {
4843 new_st.ext.iterator->novector = directive_novector;
4844 directive_novector = false;
4845 }
4846 }
4847 else
4848 stree = NULL;
4849
4850 accept_statement (ST_DO);
4851
4852 top = gfc_state_stack->tail;
4853 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
4854 gfc_new_block);
4855
4856 s.do_variable = stree;
4857
4858 top->block = new_level (top);
4859 top->block->op = EXEC_DO;
4860
4861 loop:
4862 st = parse_executable (ST_NONE);
4863
4864 switch (st)
4865 {
4866 case ST_NONE:
4867 unexpected_eof ();
4868
4869 case ST_ENDDO:
4870 if (s.ext.end_do_label != NULL
4871 && s.ext.end_do_label != gfc_statement_label)
4872 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4873 "DO label");
4874
4875 if (gfc_statement_label != NULL)
4876 {
4877 new_st.op = EXEC_NOP;
4878 add_statement ();
4879 }
4880 break;
4881
4882 case ST_IMPLIED_ENDDO:
4883 /* If the do-stmt of this DO construct has a do-construct-name,
4884 the corresponding end-do must be an end-do-stmt (with a matching
4885 name, but in that case we must have seen ST_ENDDO first).
4886 We only complain about this in pedantic mode. */
4887 if (gfc_current_block () != NULL)
4888 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4889 &gfc_current_block()->declared_at);
4890
4891 break;
4892
4893 default:
4894 unexpected_statement (st);
4895 goto loop;
4896 }
4897
4898 pop_state ();
4899 accept_statement (st);
4900 }
4901
4902
4903 /* Parse the statements of OpenMP do/parallel do. */
4904
4905 static gfc_statement
parse_omp_do(gfc_statement omp_st)4906 parse_omp_do (gfc_statement omp_st)
4907 {
4908 gfc_statement st;
4909 gfc_code *cp, *np;
4910 gfc_state_data s;
4911
4912 accept_statement (omp_st);
4913
4914 cp = gfc_state_stack->tail;
4915 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
4916 np = new_level (cp);
4917 np->op = cp->op;
4918 np->block = NULL;
4919
4920 for (;;)
4921 {
4922 st = next_statement ();
4923 if (st == ST_NONE)
4924 unexpected_eof ();
4925 else if (st == ST_DO)
4926 break;
4927 else
4928 unexpected_statement (st);
4929 }
4930
4931 parse_do_block ();
4932 if (gfc_statement_label != NULL
4933 && gfc_state_stack->previous != NULL
4934 && gfc_state_stack->previous->state == COMP_DO
4935 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
4936 {
4937 /* In
4938 DO 100 I=1,10
4939 !$OMP DO
4940 DO J=1,10
4941 ...
4942 100 CONTINUE
4943 there should be no !$OMP END DO. */
4944 pop_state ();
4945 return ST_IMPLIED_ENDDO;
4946 }
4947
4948 check_do_closure ();
4949 pop_state ();
4950
4951 st = next_statement ();
4952 gfc_statement omp_end_st = ST_OMP_END_DO;
4953 switch (omp_st)
4954 {
4955 case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
4956 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
4957 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
4958 break;
4959 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4960 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
4961 break;
4962 case ST_OMP_DISTRIBUTE_SIMD:
4963 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
4964 break;
4965 case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
4966 case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
4967 case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
4968 case ST_OMP_PARALLEL_DO_SIMD:
4969 omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
4970 break;
4971 case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
4972 case ST_OMP_TARGET_PARALLEL_DO:
4973 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
4974 break;
4975 case ST_OMP_TARGET_PARALLEL_DO_SIMD:
4976 omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
4977 break;
4978 case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
4979 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
4980 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
4981 break;
4982 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4983 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
4984 break;
4985 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4986 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
4987 break;
4988 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4989 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
4990 break;
4991 case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
4992 case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
4993 case ST_OMP_TEAMS_DISTRIBUTE:
4994 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
4995 break;
4996 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4997 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
4998 break;
4999 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5000 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5001 break;
5002 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5003 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5004 break;
5005 default: gcc_unreachable ();
5006 }
5007 if (st == omp_end_st)
5008 {
5009 if (new_st.op == EXEC_OMP_END_NOWAIT)
5010 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5011 else
5012 gcc_assert (new_st.op == EXEC_NOP);
5013 gfc_clear_new_st ();
5014 gfc_commit_symbols ();
5015 gfc_warning_check ();
5016 st = next_statement ();
5017 }
5018 return st;
5019 }
5020
5021
5022 /* Parse the statements of OpenMP atomic directive. */
5023
5024 static gfc_statement
parse_omp_oacc_atomic(bool omp_p)5025 parse_omp_oacc_atomic (bool omp_p)
5026 {
5027 gfc_statement st, st_atomic, st_end_atomic;
5028 gfc_code *cp, *np;
5029 gfc_state_data s;
5030 int count;
5031
5032 if (omp_p)
5033 {
5034 st_atomic = ST_OMP_ATOMIC;
5035 st_end_atomic = ST_OMP_END_ATOMIC;
5036 }
5037 else
5038 {
5039 st_atomic = ST_OACC_ATOMIC;
5040 st_end_atomic = ST_OACC_END_ATOMIC;
5041 }
5042 accept_statement (st_atomic);
5043
5044 cp = gfc_state_stack->tail;
5045 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5046 np = new_level (cp);
5047 np->op = cp->op;
5048 np->block = NULL;
5049 np->ext.omp_atomic = cp->ext.omp_atomic;
5050 count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
5051 == GFC_OMP_ATOMIC_CAPTURE);
5052
5053 while (count)
5054 {
5055 st = next_statement ();
5056 if (st == ST_NONE)
5057 unexpected_eof ();
5058 else if (st == ST_ASSIGNMENT)
5059 {
5060 accept_statement (st);
5061 count--;
5062 }
5063 else
5064 unexpected_statement (st);
5065 }
5066
5067 pop_state ();
5068
5069 st = next_statement ();
5070 if (st == st_end_atomic)
5071 {
5072 gfc_clear_new_st ();
5073 gfc_commit_symbols ();
5074 gfc_warning_check ();
5075 st = next_statement ();
5076 }
5077 else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
5078 == GFC_OMP_ATOMIC_CAPTURE)
5079 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
5080 return st;
5081 }
5082
5083
5084 /* Parse the statements of an OpenACC structured block. */
5085
5086 static void
parse_oacc_structured_block(gfc_statement acc_st)5087 parse_oacc_structured_block (gfc_statement acc_st)
5088 {
5089 gfc_statement st, acc_end_st;
5090 gfc_code *cp, *np;
5091 gfc_state_data s, *sd;
5092
5093 for (sd = gfc_state_stack; sd; sd = sd->previous)
5094 if (sd->state == COMP_CRITICAL)
5095 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5096
5097 accept_statement (acc_st);
5098
5099 cp = gfc_state_stack->tail;
5100 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5101 np = new_level (cp);
5102 np->op = cp->op;
5103 np->block = NULL;
5104 switch (acc_st)
5105 {
5106 case ST_OACC_PARALLEL:
5107 acc_end_st = ST_OACC_END_PARALLEL;
5108 break;
5109 case ST_OACC_KERNELS:
5110 acc_end_st = ST_OACC_END_KERNELS;
5111 break;
5112 case ST_OACC_SERIAL:
5113 acc_end_st = ST_OACC_END_SERIAL;
5114 break;
5115 case ST_OACC_DATA:
5116 acc_end_st = ST_OACC_END_DATA;
5117 break;
5118 case ST_OACC_HOST_DATA:
5119 acc_end_st = ST_OACC_END_HOST_DATA;
5120 break;
5121 default:
5122 gcc_unreachable ();
5123 }
5124
5125 do
5126 {
5127 st = parse_executable (ST_NONE);
5128 if (st == ST_NONE)
5129 unexpected_eof ();
5130 else if (st != acc_end_st)
5131 {
5132 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
5133 reject_statement ();
5134 }
5135 }
5136 while (st != acc_end_st);
5137
5138 gcc_assert (new_st.op == EXEC_NOP);
5139
5140 gfc_clear_new_st ();
5141 gfc_commit_symbols ();
5142 gfc_warning_check ();
5143 pop_state ();
5144 }
5145
5146 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5147
5148 static gfc_statement
parse_oacc_loop(gfc_statement acc_st)5149 parse_oacc_loop (gfc_statement acc_st)
5150 {
5151 gfc_statement st;
5152 gfc_code *cp, *np;
5153 gfc_state_data s, *sd;
5154
5155 for (sd = gfc_state_stack; sd; sd = sd->previous)
5156 if (sd->state == COMP_CRITICAL)
5157 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5158
5159 accept_statement (acc_st);
5160
5161 cp = gfc_state_stack->tail;
5162 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5163 np = new_level (cp);
5164 np->op = cp->op;
5165 np->block = NULL;
5166
5167 for (;;)
5168 {
5169 st = next_statement ();
5170 if (st == ST_NONE)
5171 unexpected_eof ();
5172 else if (st == ST_DO)
5173 break;
5174 else
5175 {
5176 gfc_error ("Expected DO loop at %C");
5177 reject_statement ();
5178 }
5179 }
5180
5181 parse_do_block ();
5182 if (gfc_statement_label != NULL
5183 && gfc_state_stack->previous != NULL
5184 && gfc_state_stack->previous->state == COMP_DO
5185 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5186 {
5187 pop_state ();
5188 return ST_IMPLIED_ENDDO;
5189 }
5190
5191 check_do_closure ();
5192 pop_state ();
5193
5194 st = next_statement ();
5195 if (st == ST_OACC_END_LOOP)
5196 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5197 if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
5198 (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
5199 (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
5200 (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
5201 {
5202 gcc_assert (new_st.op == EXEC_NOP);
5203 gfc_clear_new_st ();
5204 gfc_commit_symbols ();
5205 gfc_warning_check ();
5206 st = next_statement ();
5207 }
5208 return st;
5209 }
5210
5211
5212 /* Parse the statements of an OpenMP structured block. */
5213
5214 static void
parse_omp_structured_block(gfc_statement omp_st,bool workshare_stmts_only)5215 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
5216 {
5217 gfc_statement st, omp_end_st;
5218 gfc_code *cp, *np;
5219 gfc_state_data s;
5220
5221 accept_statement (omp_st);
5222
5223 cp = gfc_state_stack->tail;
5224 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5225 np = new_level (cp);
5226 np->op = cp->op;
5227 np->block = NULL;
5228
5229 switch (omp_st)
5230 {
5231 case ST_OMP_PARALLEL:
5232 omp_end_st = ST_OMP_END_PARALLEL;
5233 break;
5234 case ST_OMP_PARALLEL_SECTIONS:
5235 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
5236 break;
5237 case ST_OMP_SECTIONS:
5238 omp_end_st = ST_OMP_END_SECTIONS;
5239 break;
5240 case ST_OMP_ORDERED:
5241 omp_end_st = ST_OMP_END_ORDERED;
5242 break;
5243 case ST_OMP_CRITICAL:
5244 omp_end_st = ST_OMP_END_CRITICAL;
5245 break;
5246 case ST_OMP_MASTER:
5247 omp_end_st = ST_OMP_END_MASTER;
5248 break;
5249 case ST_OMP_SINGLE:
5250 omp_end_st = ST_OMP_END_SINGLE;
5251 break;
5252 case ST_OMP_TARGET:
5253 omp_end_st = ST_OMP_END_TARGET;
5254 break;
5255 case ST_OMP_TARGET_DATA:
5256 omp_end_st = ST_OMP_END_TARGET_DATA;
5257 break;
5258 case ST_OMP_TARGET_PARALLEL:
5259 omp_end_st = ST_OMP_END_TARGET_PARALLEL;
5260 break;
5261 case ST_OMP_TARGET_TEAMS:
5262 omp_end_st = ST_OMP_END_TARGET_TEAMS;
5263 break;
5264 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5265 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
5266 break;
5267 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5268 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5269 break;
5270 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5271 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5272 break;
5273 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5274 omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
5275 break;
5276 case ST_OMP_TASK:
5277 omp_end_st = ST_OMP_END_TASK;
5278 break;
5279 case ST_OMP_TASKGROUP:
5280 omp_end_st = ST_OMP_END_TASKGROUP;
5281 break;
5282 case ST_OMP_TEAMS:
5283 omp_end_st = ST_OMP_END_TEAMS;
5284 break;
5285 case ST_OMP_TEAMS_DISTRIBUTE:
5286 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5287 break;
5288 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5289 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
5290 break;
5291 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5292 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5293 break;
5294 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5295 omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5296 break;
5297 case ST_OMP_DISTRIBUTE:
5298 omp_end_st = ST_OMP_END_DISTRIBUTE;
5299 break;
5300 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5301 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
5302 break;
5303 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5304 omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
5305 break;
5306 case ST_OMP_DISTRIBUTE_SIMD:
5307 omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
5308 break;
5309 case ST_OMP_WORKSHARE:
5310 omp_end_st = ST_OMP_END_WORKSHARE;
5311 break;
5312 case ST_OMP_PARALLEL_WORKSHARE:
5313 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
5314 break;
5315 default:
5316 gcc_unreachable ();
5317 }
5318
5319 do
5320 {
5321 if (workshare_stmts_only)
5322 {
5323 /* Inside of !$omp workshare, only
5324 scalar assignments
5325 array assignments
5326 where statements and constructs
5327 forall statements and constructs
5328 !$omp atomic
5329 !$omp critical
5330 !$omp parallel
5331 are allowed. For !$omp critical these
5332 restrictions apply recursively. */
5333 bool cycle = true;
5334
5335 st = next_statement ();
5336 for (;;)
5337 {
5338 switch (st)
5339 {
5340 case ST_NONE:
5341 unexpected_eof ();
5342
5343 case ST_ASSIGNMENT:
5344 case ST_WHERE:
5345 case ST_FORALL:
5346 accept_statement (st);
5347 break;
5348
5349 case ST_WHERE_BLOCK:
5350 parse_where_block ();
5351 break;
5352
5353 case ST_FORALL_BLOCK:
5354 parse_forall_block ();
5355 break;
5356
5357 case ST_OMP_PARALLEL:
5358 case ST_OMP_PARALLEL_SECTIONS:
5359 parse_omp_structured_block (st, false);
5360 break;
5361
5362 case ST_OMP_PARALLEL_WORKSHARE:
5363 case ST_OMP_CRITICAL:
5364 parse_omp_structured_block (st, true);
5365 break;
5366
5367 case ST_OMP_PARALLEL_DO:
5368 case ST_OMP_PARALLEL_DO_SIMD:
5369 st = parse_omp_do (st);
5370 continue;
5371
5372 case ST_OMP_ATOMIC:
5373 st = parse_omp_oacc_atomic (true);
5374 continue;
5375
5376 default:
5377 cycle = false;
5378 break;
5379 }
5380
5381 if (!cycle)
5382 break;
5383
5384 st = next_statement ();
5385 }
5386 }
5387 else
5388 st = parse_executable (ST_NONE);
5389 if (st == ST_NONE)
5390 unexpected_eof ();
5391 else if (st == ST_OMP_SECTION
5392 && (omp_st == ST_OMP_SECTIONS
5393 || omp_st == ST_OMP_PARALLEL_SECTIONS))
5394 {
5395 np = new_level (np);
5396 np->op = cp->op;
5397 np->block = NULL;
5398 }
5399 else if (st != omp_end_st)
5400 unexpected_statement (st);
5401 }
5402 while (st != omp_end_st);
5403
5404 switch (new_st.op)
5405 {
5406 case EXEC_OMP_END_NOWAIT:
5407 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5408 break;
5409 case EXEC_OMP_END_CRITICAL:
5410 if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL))
5411 || (new_st.ext.omp_name != NULL
5412 && strcmp (cp->ext.omp_clauses->critical_name,
5413 new_st.ext.omp_name) != 0))
5414 gfc_error ("Name after !$omp critical and !$omp end critical does "
5415 "not match at %C");
5416 free (CONST_CAST (char *, new_st.ext.omp_name));
5417 new_st.ext.omp_name = NULL;
5418 break;
5419 case EXEC_OMP_END_SINGLE:
5420 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
5421 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
5422 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
5423 gfc_free_omp_clauses (new_st.ext.omp_clauses);
5424 break;
5425 case EXEC_NOP:
5426 break;
5427 default:
5428 gcc_unreachable ();
5429 }
5430
5431 gfc_clear_new_st ();
5432 gfc_commit_symbols ();
5433 gfc_warning_check ();
5434 pop_state ();
5435 }
5436
5437
5438 /* Accept a series of executable statements. We return the first
5439 statement that doesn't fit to the caller. Any block statements are
5440 passed on to the correct handler, which usually passes the buck
5441 right back here. */
5442
5443 static gfc_statement
parse_executable(gfc_statement st)5444 parse_executable (gfc_statement st)
5445 {
5446 int close_flag;
5447
5448 if (st == ST_NONE)
5449 st = next_statement ();
5450
5451 for (;;)
5452 {
5453 close_flag = check_do_closure ();
5454 if (close_flag)
5455 switch (st)
5456 {
5457 case ST_GOTO:
5458 case ST_END_PROGRAM:
5459 case ST_RETURN:
5460 case ST_EXIT:
5461 case ST_END_FUNCTION:
5462 case ST_CYCLE:
5463 case ST_PAUSE:
5464 case ST_STOP:
5465 case ST_ERROR_STOP:
5466 case ST_END_SUBROUTINE:
5467
5468 case ST_DO:
5469 case ST_FORALL:
5470 case ST_WHERE:
5471 case ST_SELECT_CASE:
5472 gfc_error ("%s statement at %C cannot terminate a non-block "
5473 "DO loop", gfc_ascii_statement (st));
5474 break;
5475
5476 default:
5477 break;
5478 }
5479
5480 switch (st)
5481 {
5482 case ST_NONE:
5483 unexpected_eof ();
5484
5485 case ST_DATA:
5486 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
5487 "first executable statement");
5488 /* Fall through. */
5489
5490 case ST_FORMAT:
5491 case ST_ENTRY:
5492 case_executable:
5493 accept_statement (st);
5494 if (close_flag == 1)
5495 return ST_IMPLIED_ENDDO;
5496 break;
5497
5498 case ST_BLOCK:
5499 parse_block_construct ();
5500 break;
5501
5502 case ST_ASSOCIATE:
5503 parse_associate ();
5504 break;
5505
5506 case ST_IF_BLOCK:
5507 parse_if_block ();
5508 break;
5509
5510 case ST_SELECT_CASE:
5511 parse_select_block ();
5512 break;
5513
5514 case ST_SELECT_TYPE:
5515 parse_select_type_block ();
5516 break;
5517
5518 case ST_SELECT_RANK:
5519 parse_select_rank_block ();
5520 break;
5521
5522 case ST_DO:
5523 parse_do_block ();
5524 if (check_do_closure () == 1)
5525 return ST_IMPLIED_ENDDO;
5526 break;
5527
5528 case ST_CRITICAL:
5529 parse_critical_block ();
5530 break;
5531
5532 case ST_WHERE_BLOCK:
5533 parse_where_block ();
5534 break;
5535
5536 case ST_FORALL_BLOCK:
5537 parse_forall_block ();
5538 break;
5539
5540 case ST_OACC_PARALLEL_LOOP:
5541 case ST_OACC_KERNELS_LOOP:
5542 case ST_OACC_SERIAL_LOOP:
5543 case ST_OACC_LOOP:
5544 st = parse_oacc_loop (st);
5545 if (st == ST_IMPLIED_ENDDO)
5546 return st;
5547 continue;
5548
5549 case ST_OACC_PARALLEL:
5550 case ST_OACC_KERNELS:
5551 case ST_OACC_SERIAL:
5552 case ST_OACC_DATA:
5553 case ST_OACC_HOST_DATA:
5554 parse_oacc_structured_block (st);
5555 break;
5556
5557 case ST_OMP_PARALLEL:
5558 case ST_OMP_PARALLEL_SECTIONS:
5559 case ST_OMP_SECTIONS:
5560 case ST_OMP_ORDERED:
5561 case ST_OMP_CRITICAL:
5562 case ST_OMP_MASTER:
5563 case ST_OMP_SINGLE:
5564 case ST_OMP_TARGET:
5565 case ST_OMP_TARGET_DATA:
5566 case ST_OMP_TARGET_PARALLEL:
5567 case ST_OMP_TARGET_TEAMS:
5568 case ST_OMP_TEAMS:
5569 case ST_OMP_TASK:
5570 case ST_OMP_TASKGROUP:
5571 parse_omp_structured_block (st, false);
5572 break;
5573
5574 case ST_OMP_WORKSHARE:
5575 case ST_OMP_PARALLEL_WORKSHARE:
5576 parse_omp_structured_block (st, true);
5577 break;
5578
5579 case ST_OMP_DISTRIBUTE:
5580 case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5581 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5582 case ST_OMP_DISTRIBUTE_SIMD:
5583 case ST_OMP_DO:
5584 case ST_OMP_DO_SIMD:
5585 case ST_OMP_PARALLEL_DO:
5586 case ST_OMP_PARALLEL_DO_SIMD:
5587 case ST_OMP_SIMD:
5588 case ST_OMP_TARGET_PARALLEL_DO:
5589 case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5590 case ST_OMP_TARGET_SIMD:
5591 case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5592 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5593 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5594 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5595 case ST_OMP_TASKLOOP:
5596 case ST_OMP_TASKLOOP_SIMD:
5597 case ST_OMP_TEAMS_DISTRIBUTE:
5598 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5599 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5600 case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5601 st = parse_omp_do (st);
5602 if (st == ST_IMPLIED_ENDDO)
5603 return st;
5604 continue;
5605
5606 case ST_OACC_ATOMIC:
5607 st = parse_omp_oacc_atomic (false);
5608 continue;
5609
5610 case ST_OMP_ATOMIC:
5611 st = parse_omp_oacc_atomic (true);
5612 continue;
5613
5614 default:
5615 return st;
5616 }
5617
5618 if (directive_unroll != -1)
5619 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5620
5621 if (directive_ivdep)
5622 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5623
5624 if (directive_vector)
5625 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5626
5627 if (directive_novector)
5628 gfc_error ("%<GCC novector%> "
5629 "directive not at the start of a loop at %C");
5630
5631 st = next_statement ();
5632 }
5633 }
5634
5635
5636 /* Fix the symbols for sibling functions. These are incorrectly added to
5637 the child namespace as the parser didn't know about this procedure. */
5638
5639 static void
gfc_fixup_sibling_symbols(gfc_symbol * sym,gfc_namespace * siblings)5640 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
5641 {
5642 gfc_namespace *ns;
5643 gfc_symtree *st;
5644 gfc_symbol *old_sym;
5645
5646 for (ns = siblings; ns; ns = ns->sibling)
5647 {
5648 st = gfc_find_symtree (ns->sym_root, sym->name);
5649
5650 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
5651 goto fixup_contained;
5652
5653 if ((st->n.sym->attr.flavor == FL_DERIVED
5654 && sym->attr.generic && sym->attr.function)
5655 ||(sym->attr.flavor == FL_DERIVED
5656 && st->n.sym->attr.generic && st->n.sym->attr.function))
5657 goto fixup_contained;
5658
5659 old_sym = st->n.sym;
5660 if (old_sym->ns == ns
5661 && !old_sym->attr.contained
5662
5663 /* By 14.6.1.3, host association should be excluded
5664 for the following. */
5665 && !(old_sym->attr.external
5666 || (old_sym->ts.type != BT_UNKNOWN
5667 && !old_sym->attr.implicit_type)
5668 || old_sym->attr.flavor == FL_PARAMETER
5669 || old_sym->attr.use_assoc
5670 || old_sym->attr.in_common
5671 || old_sym->attr.in_equivalence
5672 || old_sym->attr.data
5673 || old_sym->attr.dummy
5674 || old_sym->attr.result
5675 || old_sym->attr.dimension
5676 || old_sym->attr.allocatable
5677 || old_sym->attr.intrinsic
5678 || old_sym->attr.generic
5679 || old_sym->attr.flavor == FL_NAMELIST
5680 || old_sym->attr.flavor == FL_LABEL
5681 || old_sym->attr.proc == PROC_ST_FUNCTION))
5682 {
5683 /* Replace it with the symbol from the parent namespace. */
5684 st->n.sym = sym;
5685 sym->refs++;
5686
5687 gfc_release_symbol (old_sym);
5688 }
5689
5690 fixup_contained:
5691 /* Do the same for any contained procedures. */
5692 gfc_fixup_sibling_symbols (sym, ns->contained);
5693 }
5694 }
5695
5696 static void
parse_contained(int module)5697 parse_contained (int module)
5698 {
5699 gfc_namespace *ns, *parent_ns, *tmp;
5700 gfc_state_data s1, s2;
5701 gfc_statement st;
5702 gfc_symbol *sym;
5703 gfc_entry_list *el;
5704 locus old_loc;
5705 int contains_statements = 0;
5706 int seen_error = 0;
5707
5708 push_state (&s1, COMP_CONTAINS, NULL);
5709 parent_ns = gfc_current_ns;
5710
5711 do
5712 {
5713 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
5714
5715 gfc_current_ns->sibling = parent_ns->contained;
5716 parent_ns->contained = gfc_current_ns;
5717
5718 next:
5719 /* Process the next available statement. We come here if we got an error
5720 and rejected the last statement. */
5721 old_loc = gfc_current_locus;
5722 st = next_statement ();
5723
5724 switch (st)
5725 {
5726 case ST_NONE:
5727 unexpected_eof ();
5728
5729 case ST_FUNCTION:
5730 case ST_SUBROUTINE:
5731 contains_statements = 1;
5732 accept_statement (st);
5733
5734 push_state (&s2,
5735 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
5736 gfc_new_block);
5737
5738 /* For internal procedures, create/update the symbol in the
5739 parent namespace. */
5740
5741 if (!module)
5742 {
5743 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
5744 gfc_error ("Contained procedure %qs at %C is already "
5745 "ambiguous", gfc_new_block->name);
5746 else
5747 {
5748 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
5749 sym->name,
5750 &gfc_new_block->declared_at))
5751 {
5752 if (st == ST_FUNCTION)
5753 gfc_add_function (&sym->attr, sym->name,
5754 &gfc_new_block->declared_at);
5755 else
5756 gfc_add_subroutine (&sym->attr, sym->name,
5757 &gfc_new_block->declared_at);
5758 }
5759 }
5760
5761 gfc_commit_symbols ();
5762 }
5763 else
5764 sym = gfc_new_block;
5765
5766 /* Mark this as a contained function, so it isn't replaced
5767 by other module functions. */
5768 sym->attr.contained = 1;
5769
5770 /* Set implicit_pure so that it can be reset if any of the
5771 tests for purity fail. This is used for some optimisation
5772 during translation. */
5773 if (!sym->attr.pure)
5774 sym->attr.implicit_pure = 1;
5775
5776 parse_progunit (ST_NONE);
5777
5778 /* Fix up any sibling functions that refer to this one. */
5779 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
5780 /* Or refer to any of its alternate entry points. */
5781 for (el = gfc_current_ns->entries; el; el = el->next)
5782 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
5783
5784 gfc_current_ns->code = s2.head;
5785 gfc_current_ns = parent_ns;
5786
5787 pop_state ();
5788 break;
5789
5790 /* These statements are associated with the end of the host unit. */
5791 case ST_END_FUNCTION:
5792 case ST_END_MODULE:
5793 case ST_END_SUBMODULE:
5794 case ST_END_PROGRAM:
5795 case ST_END_SUBROUTINE:
5796 accept_statement (st);
5797 gfc_current_ns->code = s1.head;
5798 break;
5799
5800 default:
5801 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5802 gfc_ascii_statement (st));
5803 reject_statement ();
5804 seen_error = 1;
5805 goto next;
5806 break;
5807 }
5808 }
5809 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
5810 && st != ST_END_MODULE && st != ST_END_SUBMODULE
5811 && st != ST_END_PROGRAM);
5812
5813 /* The first namespace in the list is guaranteed to not have
5814 anything (worthwhile) in it. */
5815 tmp = gfc_current_ns;
5816 gfc_current_ns = parent_ns;
5817 if (seen_error && tmp->refs > 1)
5818 gfc_free_namespace (tmp);
5819
5820 ns = gfc_current_ns->contained;
5821 gfc_current_ns->contained = ns->sibling;
5822 gfc_free_namespace (ns);
5823
5824 pop_state ();
5825 if (!contains_statements)
5826 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
5827 "FUNCTION or SUBROUTINE statement at %L", &old_loc);
5828 }
5829
5830
5831 /* The result variable in a MODULE PROCEDURE needs to be created and
5832 its characteristics copied from the interface since it is neither
5833 declared in the procedure declaration nor in the specification
5834 part. */
5835
5836 static void
get_modproc_result(void)5837 get_modproc_result (void)
5838 {
5839 gfc_symbol *proc;
5840 if (gfc_state_stack->previous
5841 && gfc_state_stack->previous->state == COMP_CONTAINS
5842 && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
5843 {
5844 proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
5845 if (proc != NULL
5846 && proc->attr.function
5847 && proc->tlink
5848 && proc->tlink->result
5849 && proc->tlink->result != proc->tlink)
5850 {
5851 gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
5852 gfc_set_sym_referenced (proc->result);
5853 proc->result->attr.if_source = IFSRC_DECL;
5854 gfc_commit_symbol (proc->result);
5855 }
5856 }
5857 }
5858
5859
5860 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5861
5862 static void
parse_progunit(gfc_statement st)5863 parse_progunit (gfc_statement st)
5864 {
5865 gfc_state_data *p;
5866 int n;
5867
5868 gfc_adjust_builtins ();
5869
5870 if (gfc_new_block
5871 && gfc_new_block->abr_modproc_decl
5872 && gfc_new_block->attr.function)
5873 get_modproc_result ();
5874
5875 st = parse_spec (st);
5876 switch (st)
5877 {
5878 case ST_NONE:
5879 unexpected_eof ();
5880
5881 case ST_CONTAINS:
5882 /* This is not allowed within BLOCK! */
5883 if (gfc_current_state () != COMP_BLOCK)
5884 goto contains;
5885 break;
5886
5887 case_end:
5888 accept_statement (st);
5889 goto done;
5890
5891 default:
5892 break;
5893 }
5894
5895 if (gfc_current_state () == COMP_FUNCTION)
5896 gfc_check_function_type (gfc_current_ns);
5897
5898 loop:
5899 for (;;)
5900 {
5901 st = parse_executable (st);
5902
5903 switch (st)
5904 {
5905 case ST_NONE:
5906 unexpected_eof ();
5907
5908 case ST_CONTAINS:
5909 /* This is not allowed within BLOCK! */
5910 if (gfc_current_state () != COMP_BLOCK)
5911 goto contains;
5912 break;
5913
5914 case_end:
5915 accept_statement (st);
5916 goto done;
5917
5918 default:
5919 break;
5920 }
5921
5922 unexpected_statement (st);
5923 reject_statement ();
5924 st = next_statement ();
5925 }
5926
5927 contains:
5928 n = 0;
5929
5930 for (p = gfc_state_stack; p; p = p->previous)
5931 if (p->state == COMP_CONTAINS)
5932 n++;
5933
5934 if (gfc_find_state (COMP_MODULE) == true
5935 || gfc_find_state (COMP_SUBMODULE) == true)
5936 n--;
5937
5938 if (n > 0)
5939 {
5940 gfc_error ("CONTAINS statement at %C is already in a contained "
5941 "program unit");
5942 reject_statement ();
5943 st = next_statement ();
5944 goto loop;
5945 }
5946
5947 parse_contained (0);
5948
5949 done:
5950 gfc_current_ns->code = gfc_state_stack->head;
5951 }
5952
5953
5954 /* Come here to complain about a global symbol already in use as
5955 something else. */
5956
5957 void
gfc_global_used(gfc_gsymbol * sym,locus * where)5958 gfc_global_used (gfc_gsymbol *sym, locus *where)
5959 {
5960 const char *name;
5961
5962 if (where == NULL)
5963 where = &gfc_current_locus;
5964
5965 switch(sym->type)
5966 {
5967 case GSYM_PROGRAM:
5968 name = "PROGRAM";
5969 break;
5970 case GSYM_FUNCTION:
5971 name = "FUNCTION";
5972 break;
5973 case GSYM_SUBROUTINE:
5974 name = "SUBROUTINE";
5975 break;
5976 case GSYM_COMMON:
5977 name = "COMMON";
5978 break;
5979 case GSYM_BLOCK_DATA:
5980 name = "BLOCK DATA";
5981 break;
5982 case GSYM_MODULE:
5983 name = "MODULE";
5984 break;
5985 default:
5986 name = NULL;
5987 }
5988
5989 if (name)
5990 {
5991 if (sym->binding_label)
5992 gfc_error ("Global binding name %qs at %L is already being used "
5993 "as a %s at %L", sym->binding_label, where, name,
5994 &sym->where);
5995 else
5996 gfc_error ("Global name %qs at %L is already being used as "
5997 "a %s at %L", sym->name, where, name, &sym->where);
5998 }
5999 else
6000 {
6001 if (sym->binding_label)
6002 gfc_error ("Global binding name %qs at %L is already being used "
6003 "at %L", sym->binding_label, where, &sym->where);
6004 else
6005 gfc_error ("Global name %qs at %L is already being used at %L",
6006 sym->name, where, &sym->where);
6007 }
6008 }
6009
6010
6011 /* Parse a block data program unit. */
6012
6013 static void
parse_block_data(void)6014 parse_block_data (void)
6015 {
6016 gfc_statement st;
6017 static locus blank_locus;
6018 static int blank_block=0;
6019 gfc_gsymbol *s;
6020
6021 gfc_current_ns->proc_name = gfc_new_block;
6022 gfc_current_ns->is_block_data = 1;
6023
6024 if (gfc_new_block == NULL)
6025 {
6026 if (blank_block)
6027 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6028 "prior BLOCK DATA at %L", &blank_locus);
6029 else
6030 {
6031 blank_block = 1;
6032 blank_locus = gfc_current_locus;
6033 }
6034 }
6035 else
6036 {
6037 s = gfc_get_gsymbol (gfc_new_block->name, false);
6038 if (s->defined
6039 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
6040 gfc_global_used (s, &gfc_new_block->declared_at);
6041 else
6042 {
6043 s->type = GSYM_BLOCK_DATA;
6044 s->where = gfc_new_block->declared_at;
6045 s->defined = 1;
6046 }
6047 }
6048
6049 st = parse_spec (ST_NONE);
6050
6051 while (st != ST_END_BLOCK_DATA)
6052 {
6053 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6054 gfc_ascii_statement (st));
6055 reject_statement ();
6056 st = next_statement ();
6057 }
6058 }
6059
6060
6061 /* Following the association of the ancestor (sub)module symbols, they
6062 must be set host rather than use associated and all must be public.
6063 They are flagged up by 'used_in_submodule' so that they can be set
6064 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6065 linker chokes on multiple symbol definitions. */
6066
6067 static void
set_syms_host_assoc(gfc_symbol * sym)6068 set_syms_host_assoc (gfc_symbol *sym)
6069 {
6070 gfc_component *c;
6071 const char dot[2] = ".";
6072 /* Symbols take the form module.submodule_ or module.name_. */
6073 char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
6074 char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
6075
6076 if (sym == NULL)
6077 return;
6078
6079 if (sym->attr.module_procedure)
6080 sym->attr.external = 0;
6081
6082 sym->attr.use_assoc = 0;
6083 sym->attr.host_assoc = 1;
6084 sym->attr.used_in_submodule =1;
6085
6086 if (sym->attr.flavor == FL_DERIVED)
6087 {
6088 /* Derived types with PRIVATE components that are declared in
6089 modules other than the parent module must not be changed to be
6090 PUBLIC. The 'use-assoc' attribute must be reset so that the
6091 test in symbol.c(gfc_find_component) works correctly. This is
6092 not necessary for PRIVATE symbols since they are not read from
6093 the module. */
6094 memset(parent1, '\0', sizeof(parent1));
6095 memset(parent2, '\0', sizeof(parent2));
6096 strcpy (parent1, gfc_new_block->name);
6097 strcpy (parent2, sym->module);
6098 if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
6099 {
6100 for (c = sym->components; c; c = c->next)
6101 c->attr.access = ACCESS_PUBLIC;
6102 }
6103 else
6104 {
6105 sym->attr.use_assoc = 1;
6106 sym->attr.host_assoc = 0;
6107 }
6108 }
6109 }
6110
6111 /* Parse a module subprogram. */
6112
6113 static void
parse_module(void)6114 parse_module (void)
6115 {
6116 gfc_statement st;
6117 gfc_gsymbol *s;
6118 bool error;
6119
6120 s = gfc_get_gsymbol (gfc_new_block->name, false);
6121 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
6122 gfc_global_used (s, &gfc_new_block->declared_at);
6123 else
6124 {
6125 s->type = GSYM_MODULE;
6126 s->where = gfc_new_block->declared_at;
6127 s->defined = 1;
6128 }
6129
6130 /* Something is nulling the module_list after this point. This is good
6131 since it allows us to 'USE' the parent modules that the submodule
6132 inherits and to set (most) of the symbols as host associated. */
6133 if (gfc_current_state () == COMP_SUBMODULE)
6134 {
6135 use_modules ();
6136 gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
6137 }
6138
6139 st = parse_spec (ST_NONE);
6140
6141 error = false;
6142 loop:
6143 switch (st)
6144 {
6145 case ST_NONE:
6146 unexpected_eof ();
6147
6148 case ST_CONTAINS:
6149 parse_contained (1);
6150 break;
6151
6152 case ST_END_MODULE:
6153 case ST_END_SUBMODULE:
6154 accept_statement (st);
6155 break;
6156
6157 default:
6158 gfc_error ("Unexpected %s statement in MODULE at %C",
6159 gfc_ascii_statement (st));
6160
6161 error = true;
6162 reject_statement ();
6163 st = next_statement ();
6164 goto loop;
6165 }
6166
6167 /* Make sure not to free the namespace twice on error. */
6168 if (!error)
6169 s->ns = gfc_current_ns;
6170 }
6171
6172
6173 /* Add a procedure name to the global symbol table. */
6174
6175 static void
add_global_procedure(bool sub)6176 add_global_procedure (bool sub)
6177 {
6178 gfc_gsymbol *s;
6179
6180 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6181 name is a global identifier. */
6182 if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
6183 {
6184 s = gfc_get_gsymbol (gfc_new_block->name, false);
6185
6186 if (s->defined
6187 || (s->type != GSYM_UNKNOWN
6188 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6189 {
6190 gfc_global_used (s, &gfc_new_block->declared_at);
6191 /* Silence follow-up errors. */
6192 gfc_new_block->binding_label = NULL;
6193 }
6194 else
6195 {
6196 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6197 s->sym_name = gfc_new_block->name;
6198 s->where = gfc_new_block->declared_at;
6199 s->defined = 1;
6200 s->ns = gfc_current_ns;
6201 }
6202 }
6203
6204 /* Don't add the symbol multiple times. */
6205 if (gfc_new_block->binding_label
6206 && (!gfc_notification_std (GFC_STD_F2008)
6207 || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
6208 {
6209 s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
6210
6211 if (s->defined
6212 || (s->type != GSYM_UNKNOWN
6213 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6214 {
6215 gfc_global_used (s, &gfc_new_block->declared_at);
6216 /* Silence follow-up errors. */
6217 gfc_new_block->binding_label = NULL;
6218 }
6219 else
6220 {
6221 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6222 s->sym_name = gfc_new_block->name;
6223 s->binding_label = gfc_new_block->binding_label;
6224 s->where = gfc_new_block->declared_at;
6225 s->defined = 1;
6226 s->ns = gfc_current_ns;
6227 }
6228 }
6229 }
6230
6231
6232 /* Add a program to the global symbol table. */
6233
6234 static void
add_global_program(void)6235 add_global_program (void)
6236 {
6237 gfc_gsymbol *s;
6238
6239 if (gfc_new_block == NULL)
6240 return;
6241 s = gfc_get_gsymbol (gfc_new_block->name, false);
6242
6243 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
6244 gfc_global_used (s, &gfc_new_block->declared_at);
6245 else
6246 {
6247 s->type = GSYM_PROGRAM;
6248 s->where = gfc_new_block->declared_at;
6249 s->defined = 1;
6250 s->ns = gfc_current_ns;
6251 }
6252 }
6253
6254
6255 /* Resolve all the program units. */
6256 static void
resolve_all_program_units(gfc_namespace * gfc_global_ns_list)6257 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
6258 {
6259 gfc_derived_types = NULL;
6260 gfc_current_ns = gfc_global_ns_list;
6261 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6262 {
6263 if (gfc_current_ns->proc_name
6264 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6265 continue; /* Already resolved. */
6266
6267 if (gfc_current_ns->proc_name)
6268 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6269 gfc_resolve (gfc_current_ns);
6270 gfc_current_ns->derived_types = gfc_derived_types;
6271 gfc_derived_types = NULL;
6272 }
6273 }
6274
6275
6276 static void
clean_up_modules(gfc_gsymbol * gsym)6277 clean_up_modules (gfc_gsymbol *gsym)
6278 {
6279 if (gsym == NULL)
6280 return;
6281
6282 clean_up_modules (gsym->left);
6283 clean_up_modules (gsym->right);
6284
6285 if (gsym->type != GSYM_MODULE || !gsym->ns)
6286 return;
6287
6288 gfc_current_ns = gsym->ns;
6289 gfc_derived_types = gfc_current_ns->derived_types;
6290 gfc_done_2 ();
6291 gsym->ns = NULL;
6292 return;
6293 }
6294
6295
6296 /* Translate all the program units. This could be in a different order
6297 to resolution if there are forward references in the file. */
6298 static void
translate_all_program_units(gfc_namespace * gfc_global_ns_list)6299 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
6300 {
6301 int errors;
6302
6303 gfc_current_ns = gfc_global_ns_list;
6304 gfc_get_errors (NULL, &errors);
6305
6306 /* We first translate all modules to make sure that later parts
6307 of the program can use the decl. Then we translate the nonmodules. */
6308
6309 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6310 {
6311 if (!gfc_current_ns->proc_name
6312 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6313 continue;
6314
6315 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6316 gfc_derived_types = gfc_current_ns->derived_types;
6317 gfc_generate_module_code (gfc_current_ns);
6318 gfc_current_ns->translated = 1;
6319 }
6320
6321 gfc_current_ns = gfc_global_ns_list;
6322 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6323 {
6324 if (gfc_current_ns->proc_name
6325 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6326 continue;
6327
6328 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6329 gfc_derived_types = gfc_current_ns->derived_types;
6330 gfc_generate_code (gfc_current_ns);
6331 gfc_current_ns->translated = 1;
6332 }
6333
6334 /* Clean up all the namespaces after translation. */
6335 gfc_current_ns = gfc_global_ns_list;
6336 for (;gfc_current_ns;)
6337 {
6338 gfc_namespace *ns;
6339
6340 if (gfc_current_ns->proc_name
6341 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6342 {
6343 gfc_current_ns = gfc_current_ns->sibling;
6344 continue;
6345 }
6346
6347 ns = gfc_current_ns->sibling;
6348 gfc_derived_types = gfc_current_ns->derived_types;
6349 gfc_done_2 ();
6350 gfc_current_ns = ns;
6351 }
6352
6353 clean_up_modules (gfc_gsym_root);
6354 }
6355
6356
6357 /* Top level parser. */
6358
6359 bool
gfc_parse_file(void)6360 gfc_parse_file (void)
6361 {
6362 int seen_program, errors_before, errors;
6363 gfc_state_data top, s;
6364 gfc_statement st;
6365 locus prog_locus;
6366 gfc_namespace *next;
6367
6368 gfc_start_source_files ();
6369
6370 top.state = COMP_NONE;
6371 top.sym = NULL;
6372 top.previous = NULL;
6373 top.head = top.tail = NULL;
6374 top.do_variable = NULL;
6375
6376 gfc_state_stack = ⊤
6377
6378 gfc_clear_new_st ();
6379
6380 gfc_statement_label = NULL;
6381
6382 if (setjmp (eof_buf))
6383 return false; /* Come here on unexpected EOF */
6384
6385 /* Prepare the global namespace that will contain the
6386 program units. */
6387 gfc_global_ns_list = next = NULL;
6388
6389 seen_program = 0;
6390 errors_before = 0;
6391
6392 /* Exit early for empty files. */
6393 if (gfc_at_eof ())
6394 goto done;
6395
6396 in_specification_block = true;
6397 loop:
6398 gfc_init_2 ();
6399 st = next_statement ();
6400 switch (st)
6401 {
6402 case ST_NONE:
6403 gfc_done_2 ();
6404 goto done;
6405
6406 case ST_PROGRAM:
6407 if (seen_program)
6408 goto duplicate_main;
6409 seen_program = 1;
6410 prog_locus = gfc_current_locus;
6411
6412 push_state (&s, COMP_PROGRAM, gfc_new_block);
6413 main_program_symbol (gfc_current_ns, gfc_new_block->name);
6414 accept_statement (st);
6415 add_global_program ();
6416 parse_progunit (ST_NONE);
6417 goto prog_units;
6418
6419 case ST_SUBROUTINE:
6420 add_global_procedure (true);
6421 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
6422 accept_statement (st);
6423 parse_progunit (ST_NONE);
6424 goto prog_units;
6425
6426 case ST_FUNCTION:
6427 add_global_procedure (false);
6428 push_state (&s, COMP_FUNCTION, gfc_new_block);
6429 accept_statement (st);
6430 parse_progunit (ST_NONE);
6431 goto prog_units;
6432
6433 case ST_BLOCK_DATA:
6434 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
6435 accept_statement (st);
6436 parse_block_data ();
6437 break;
6438
6439 case ST_MODULE:
6440 push_state (&s, COMP_MODULE, gfc_new_block);
6441 accept_statement (st);
6442
6443 gfc_get_errors (NULL, &errors_before);
6444 parse_module ();
6445 break;
6446
6447 case ST_SUBMODULE:
6448 push_state (&s, COMP_SUBMODULE, gfc_new_block);
6449 accept_statement (st);
6450
6451 gfc_get_errors (NULL, &errors_before);
6452 parse_module ();
6453 break;
6454
6455 /* Anything else starts a nameless main program block. */
6456 default:
6457 if (seen_program)
6458 goto duplicate_main;
6459 seen_program = 1;
6460 prog_locus = gfc_current_locus;
6461
6462 push_state (&s, COMP_PROGRAM, gfc_new_block);
6463 main_program_symbol (gfc_current_ns, "MAIN__");
6464 parse_progunit (st);
6465 goto prog_units;
6466 }
6467
6468 /* Handle the non-program units. */
6469 gfc_current_ns->code = s.head;
6470
6471 gfc_resolve (gfc_current_ns);
6472
6473 /* Fix the implicit_pure attribute for those procedures who should
6474 not have it. */
6475 while (gfc_fix_implicit_pure (gfc_current_ns))
6476 ;
6477
6478 /* Dump the parse tree if requested. */
6479 if (flag_dump_fortran_original)
6480 gfc_dump_parse_tree (gfc_current_ns, stdout);
6481
6482 gfc_get_errors (NULL, &errors);
6483 if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
6484 {
6485 gfc_dump_module (s.sym->name, errors_before == errors);
6486 gfc_current_ns->derived_types = gfc_derived_types;
6487 gfc_derived_types = NULL;
6488 goto prog_units;
6489 }
6490 else
6491 {
6492 if (errors == 0)
6493 gfc_generate_code (gfc_current_ns);
6494 pop_state ();
6495 gfc_done_2 ();
6496 }
6497
6498 goto loop;
6499
6500 prog_units:
6501 /* The main program and non-contained procedures are put
6502 in the global namespace list, so that they can be processed
6503 later and all their interfaces resolved. */
6504 gfc_current_ns->code = s.head;
6505 if (next)
6506 {
6507 for (; next->sibling; next = next->sibling)
6508 ;
6509 next->sibling = gfc_current_ns;
6510 }
6511 else
6512 gfc_global_ns_list = gfc_current_ns;
6513
6514 next = gfc_current_ns;
6515
6516 pop_state ();
6517 goto loop;
6518
6519 done:
6520 /* Do the resolution. */
6521 resolve_all_program_units (gfc_global_ns_list);
6522
6523 /* Go through all top-level namespaces and unset the implicit_pure
6524 attribute for any procedures that call something not pure or
6525 implicit_pure. Because the a procedure marked as not implicit_pure
6526 in one sweep may be called by another routine, we repeat this
6527 process until there are no more changes. */
6528 bool changed;
6529 do
6530 {
6531 changed = false;
6532 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6533 gfc_current_ns = gfc_current_ns->sibling)
6534 {
6535 if (gfc_fix_implicit_pure (gfc_current_ns))
6536 changed = true;
6537 }
6538 }
6539 while (changed);
6540
6541 /* Fixup for external procedures. */
6542 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6543 gfc_current_ns = gfc_current_ns->sibling)
6544 gfc_check_externals (gfc_current_ns);
6545
6546 /* Do the parse tree dump. */
6547 gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
6548
6549 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6550 if (!gfc_current_ns->proc_name
6551 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6552 {
6553 gfc_dump_parse_tree (gfc_current_ns, stdout);
6554 fputs ("------------------------------------------\n\n", stdout);
6555 }
6556
6557 /* Dump C prototypes. */
6558 if (flag_c_prototypes || flag_c_prototypes_external)
6559 {
6560 fprintf (stdout,
6561 "#include <stddef.h>\n"
6562 "#ifdef __cplusplus\n"
6563 "#include <complex>\n"
6564 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6565 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6566 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6567 "extern \"C\" {\n"
6568 "#else\n"
6569 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6570 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6571 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6572 "#endif\n\n");
6573 }
6574
6575 /* First dump BIND(C) prototypes. */
6576 if (flag_c_prototypes)
6577 {
6578 for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6579 gfc_current_ns = gfc_current_ns->sibling)
6580 gfc_dump_c_prototypes (gfc_current_ns, stdout);
6581 }
6582
6583 /* Dump external prototypes. */
6584 if (flag_c_prototypes_external)
6585 gfc_dump_external_c_prototypes (stdout);
6586
6587 if (flag_c_prototypes || flag_c_prototypes_external)
6588 fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
6589
6590 /* Do the translation. */
6591 translate_all_program_units (gfc_global_ns_list);
6592
6593 /* Dump the global symbol ist. We only do this here because part
6594 of it is generated after mangling the identifiers in
6595 trans-decl.c. */
6596
6597 if (flag_dump_fortran_global)
6598 gfc_dump_global_symbols (stdout);
6599
6600 gfc_end_source_files ();
6601 return true;
6602
6603 duplicate_main:
6604 /* If we see a duplicate main program, shut down. If the second
6605 instance is an implied main program, i.e. data decls or executable
6606 statements, we're in for lots of errors. */
6607 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
6608 reject_statement ();
6609 gfc_done_2 ();
6610 return true;
6611 }
6612
6613 /* Return true if this state data represents an OpenACC region. */
6614 bool
is_oacc(gfc_state_data * sd)6615 is_oacc (gfc_state_data *sd)
6616 {
6617 switch (sd->construct->op)
6618 {
6619 case EXEC_OACC_PARALLEL_LOOP:
6620 case EXEC_OACC_PARALLEL:
6621 case EXEC_OACC_KERNELS_LOOP:
6622 case EXEC_OACC_KERNELS:
6623 case EXEC_OACC_SERIAL_LOOP:
6624 case EXEC_OACC_SERIAL:
6625 case EXEC_OACC_DATA:
6626 case EXEC_OACC_HOST_DATA:
6627 case EXEC_OACC_LOOP:
6628 case EXEC_OACC_UPDATE:
6629 case EXEC_OACC_WAIT:
6630 case EXEC_OACC_CACHE:
6631 case EXEC_OACC_ENTER_DATA:
6632 case EXEC_OACC_EXIT_DATA:
6633 case EXEC_OACC_ATOMIC:
6634 case EXEC_OACC_ROUTINE:
6635 return true;
6636
6637 default:
6638 return false;
6639 }
6640 }
6641