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