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