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