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