projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/40881 ([F03] warn for obsolescent features)
[gcc.git] / gcc / fortran / parse.c
1 /* Main parser.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3 2009, 2010, 2011, 2012
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
22
23 #include "config.h"
24 #include "system.h"
25 #include <setjmp.h>
26 #include "coretypes.h"
27 #include "gfortran.h"
28 #include "match.h"
29 #include "parse.h"
30 #include "debug.h"
31
32 /* Current statement label. Zero means no statement label. Because new_st
33 can get wiped during statement matching, we have to keep it separate. */
34
35 gfc_st_label *gfc_statement_label;
36
37 static locus label_locus;
38 static jmp_buf eof_buf;
39
40 gfc_state_data *gfc_state_stack;
41 static bool last_was_use_stmt = false;
42
43 /* TODO: Re-order functions to kill these forward decls. */
44 static void check_statement_label (gfc_statement);
45 static void undo_new_statement (void);
46 static void reject_statement (void);
47
48
49 /* A sort of half-matching function. We try to match the word on the
50 input with the passed string. If this succeeds, we call the
51 keyword-dependent matching function that will match the rest of the
52 statement. For single keywords, the matching subroutine is
53 gfc_match_eos(). */
54
55 static match
56 match_word (const char *str, match (*subr) (void), locus *old_locus)
57 {
58 match m;
59
60 if (str != NULL)
61 {
62 m = gfc_match (str);
63 if (m != MATCH_YES)
64 return m;
65 }
66
67 m = (*subr) ();
68
69 if (m != MATCH_YES)
70 {
71 gfc_current_locus = *old_locus;
72 reject_statement ();
73 }
74
75 return m;
76 }
77
78
79 /* Load symbols from all USE statements encountered in this scoping unit. */
80
81 static void
82 use_modules (void)
83 {
84 gfc_error_buf old_error;
85
86 gfc_push_error (&old_error);
87 gfc_buffer_error (0);
88 gfc_use_modules ();
89 gfc_buffer_error (1);
90 gfc_pop_error (&old_error);
91 gfc_commit_symbols ();
92 gfc_warning_check ();
93 gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
94 gfc_current_ns->old_equiv = gfc_current_ns->equiv;
95 last_was_use_stmt = false;
96 }
97
98
99 /* Figure out what the next statement is, (mostly) regardless of
100 proper ordering. The do...while(0) is there to prevent if/else
101 ambiguity. */
102
103 #define match(keyword, subr, st) \
104 do { \
105 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
106 return st; \
107 else \
108 undo_new_statement (); \
109 } while (0);
110
111
112 /* This is a specialist version of decode_statement that is used
113 for the specification statements in a function, whose
114 characteristics are deferred into the specification statements.
115 eg.: INTEGER (king = mykind) foo ()
116 USE mymodule, ONLY mykind.....
117 The KIND parameter needs a return after USE or IMPORT, whereas
118 derived type declarations can occur anywhere, up the executable
119 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
120 out of the correct kind of specification statements. */
121 static gfc_statement
122 decode_specification_statement (void)
123 {
124 gfc_statement st;
125 locus old_locus;
126 char c;
127
128 if (gfc_match_eos () == MATCH_YES)
129 return ST_NONE;
130
131 old_locus = gfc_current_locus;
132
133 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
134 {
135 last_was_use_stmt = true;
136 return ST_USE;
137 }
138 else
139 {
140 undo_new_statement ();
141 if (last_was_use_stmt)
142 use_modules ();
143 }
144
145 match ("import", gfc_match_import, ST_IMPORT);
146
147 if (gfc_current_block ()->result->ts.type != BT_DERIVED)
148 goto end_of_block;
149
150 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
151 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
152 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
153
154 /* General statement matching: Instead of testing every possible
155 statement, we eliminate most possibilities by peeking at the
156 first character. */
157
158 c = gfc_peek_ascii_char ();
159
160 switch (c)
161 {
162 case 'a':
163 match ("abstract% interface", gfc_match_abstract_interface,
164 ST_INTERFACE);
165 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
166 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
167 break;
168
169 case 'b':
170 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
171 break;
172
173 case 'c':
174 match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
175 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
176 break;
177
178 case 'd':
179 match ("data", gfc_match_data, ST_DATA);
180 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
181 break;
182
183 case 'e':
184 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
185 match ("entry% ", gfc_match_entry, ST_ENTRY);
186 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
187 match ("external", gfc_match_external, ST_ATTR_DECL);
188 break;
189
190 case 'f':
191 match ("format", gfc_match_format, ST_FORMAT);
192 break;
193
194 case 'g':
195 break;
196
197 case 'i':
198 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
199 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
200 match ("interface", gfc_match_interface, ST_INTERFACE);
201 match ("intent", gfc_match_intent, ST_ATTR_DECL);
202 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
203 break;
204
205 case 'm':
206 break;
207
208 case 'n':
209 match ("namelist", gfc_match_namelist, ST_NAMELIST);
210 break;
211
212 case 'o':
213 match ("optional", gfc_match_optional, ST_ATTR_DECL);
214 break;
215
216 case 'p':
217 match ("parameter", gfc_match_parameter, ST_PARAMETER);
218 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
219 if (gfc_match_private (&st) == MATCH_YES)
220 return st;
221 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
222 if (gfc_match_public (&st) == MATCH_YES)
223 return st;
224 match ("protected", gfc_match_protected, ST_ATTR_DECL);
225 break;
226
227 case 'r':
228 break;
229
230 case 's':
231 match ("save", gfc_match_save, ST_ATTR_DECL);
232 break;
233
234 case 't':
235 match ("target", gfc_match_target, ST_ATTR_DECL);
236 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
237 break;
238
239 case 'u':
240 break;
241
242 case 'v':
243 match ("value", gfc_match_value, ST_ATTR_DECL);
244 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
245 break;
246
247 case 'w':
248 break;
249 }
250
251 /* This is not a specification statement. See if any of the matchers
252 has stored an error message of some sort. */
253
254 end_of_block:
255 gfc_clear_error ();
256 gfc_buffer_error (0);
257 gfc_current_locus = old_locus;
258
259 return ST_GET_FCN_CHARACTERISTICS;
260 }
261
262
263 /* This is the primary 'decode_statement'. */
264 static gfc_statement
265 decode_statement (void)
266 {
267 gfc_statement st;
268 locus old_locus;
269 match m;
270 char c;
271
272 gfc_enforce_clean_symbol_state ();
273
274 gfc_clear_error (); /* Clear any pending errors. */
275 gfc_clear_warning (); /* Clear any pending warnings. */
276
277 gfc_matching_function = false;
278
279 if (gfc_match_eos () == MATCH_YES)
280 return ST_NONE;
281
282 if (gfc_current_state () == COMP_FUNCTION
283 && gfc_current_block ()->result->ts.kind == -1)
284 return decode_specification_statement ();
285
286 old_locus = gfc_current_locus;
287
288 c = gfc_peek_ascii_char ();
289
290 if (c == 'u')
291 {
292 if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
293 {
294 last_was_use_stmt = true;
295 return ST_USE;
296 }
297 else
298 undo_new_statement ();
299 }
300
301 if (last_was_use_stmt)
302 use_modules ();
303
304 /* Try matching a data declaration or function declaration. The
305 input "REALFUNCTIONA(N)" can mean several things in different
306 contexts, so it (and its relatives) get special treatment. */
307
308 if (gfc_current_state () == COMP_NONE
309 || gfc_current_state () == COMP_INTERFACE
310 || gfc_current_state () == COMP_CONTAINS)
311 {
312 gfc_matching_function = true;
313 m = gfc_match_function_decl ();
314 if (m == MATCH_YES)
315 return ST_FUNCTION;
316 else if (m == MATCH_ERROR)
317 reject_statement ();
318 else
319 gfc_undo_symbols ();
320 gfc_current_locus = old_locus;
321 }
322 gfc_matching_function = false;
323
324
325 /* Match statements whose error messages are meant to be overwritten
326 by something better. */
327
328 match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
329 match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
330 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
331
332 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
333 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
334
335 /* Try to match a subroutine statement, which has the same optional
336 prefixes that functions can have. */
337
338 if (gfc_match_subroutine () == MATCH_YES)
339 return ST_SUBROUTINE;
340 gfc_undo_symbols ();
341 gfc_current_locus = old_locus;
342
343 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
344 statements, which might begin with a block label. The match functions for
345 these statements are unusual in that their keyword is not seen before
346 the matcher is called. */
347
348 if (gfc_match_if (&st) == MATCH_YES)
349 return st;
350 gfc_undo_symbols ();
351 gfc_current_locus = old_locus;
352
353 if (gfc_match_where (&st) == MATCH_YES)
354 return st;
355 gfc_undo_symbols ();
356 gfc_current_locus = old_locus;
357
358 if (gfc_match_forall (&st) == MATCH_YES)
359 return st;
360 gfc_undo_symbols ();
361 gfc_current_locus = old_locus;
362
363 match (NULL, gfc_match_do, ST_DO);
364 match (NULL, gfc_match_block, ST_BLOCK);
365 match (NULL, gfc_match_associate, ST_ASSOCIATE);
366 match (NULL, gfc_match_critical, ST_CRITICAL);
367 match (NULL, gfc_match_select, ST_SELECT_CASE);
368 match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
369
370 /* General statement matching: Instead of testing every possible
371 statement, we eliminate most possibilities by peeking at the
372 first character. */
373
374 switch (c)
375 {
376 case 'a':
377 match ("abstract% interface", gfc_match_abstract_interface,
378 ST_INTERFACE);
379 match ("allocate", gfc_match_allocate, ST_ALLOCATE);
380 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
381 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
382 match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
383 break;
384
385 case 'b':
386 match ("backspace", gfc_match_backspace, ST_BACKSPACE);
387 match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
388 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
389 break;
390
391 case 'c':
392 match ("call", gfc_match_call, ST_CALL);
393 match ("close", gfc_match_close, ST_CLOSE);
394 match ("continue", gfc_match_continue, ST_CONTINUE);
395 match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
396 match ("cycle", gfc_match_cycle, ST_CYCLE);
397 match ("case", gfc_match_case, ST_CASE);
398 match ("common", gfc_match_common, ST_COMMON);
399 match ("contains", gfc_match_eos, ST_CONTAINS);
400 match ("class", gfc_match_class_is, ST_CLASS_IS);
401 match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
402 break;
403
404 case 'd':
405 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
406 match ("data", gfc_match_data, ST_DATA);
407 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
408 break;
409
410 case 'e':
411 match ("end file", gfc_match_endfile, ST_END_FILE);
412 match ("exit", gfc_match_exit, ST_EXIT);
413 match ("else", gfc_match_else, ST_ELSE);
414 match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
415 match ("else if", gfc_match_elseif, ST_ELSEIF);
416 match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
417 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
418
419 if (gfc_match_end (&st) == MATCH_YES)
420 return st;
421
422 match ("entry% ", gfc_match_entry, ST_ENTRY);
423 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
424 match ("external", gfc_match_external, ST_ATTR_DECL);
425 break;
426
427 case 'f':
428 match ("final", gfc_match_final_decl, ST_FINAL);
429 match ("flush", gfc_match_flush, ST_FLUSH);
430 match ("format", gfc_match_format, ST_FORMAT);
431 break;
432
433 case 'g':
434 match ("generic", gfc_match_generic, ST_GENERIC);
435 match ("go to", gfc_match_goto, ST_GOTO);
436 break;
437
438 case 'i':
439 match ("inquire", gfc_match_inquire, ST_INQUIRE);
440 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
441 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
442 match ("import", gfc_match_import, ST_IMPORT);
443 match ("interface", gfc_match_interface, ST_INTERFACE);
444 match ("intent", gfc_match_intent, ST_ATTR_DECL);
445 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
446 break;
447
448 case 'l':
449 match ("lock", gfc_match_lock, ST_LOCK);
450 break;
451
452 case 'm':
453 match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
454 match ("module", gfc_match_module, ST_MODULE);
455 break;
456
457 case 'n':
458 match ("nullify", gfc_match_nullify, ST_NULLIFY);
459 match ("namelist", gfc_match_namelist, ST_NAMELIST);
460 break;
461
462 case 'o':
463 match ("open", gfc_match_open, ST_OPEN);
464 match ("optional", gfc_match_optional, ST_ATTR_DECL);
465 break;
466
467 case 'p':
468 match ("print", gfc_match_print, ST_WRITE);
469 match ("parameter", gfc_match_parameter, ST_PARAMETER);
470 match ("pause", gfc_match_pause, ST_PAUSE);
471 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
472 if (gfc_match_private (&st) == MATCH_YES)
473 return st;
474 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
475 match ("program", gfc_match_program, ST_PROGRAM);
476 if (gfc_match_public (&st) == MATCH_YES)
477 return st;
478 match ("protected", gfc_match_protected, ST_ATTR_DECL);
479 break;
480
481 case 'r':
482 match ("read", gfc_match_read, ST_READ);
483 match ("return", gfc_match_return, ST_RETURN);
484 match ("rewind", gfc_match_rewind, ST_REWIND);
485 break;
486
487 case 's':
488 match ("sequence", gfc_match_eos, ST_SEQUENCE);
489 match ("stop", gfc_match_stop, ST_STOP);
490 match ("save", gfc_match_save, ST_ATTR_DECL);
491 match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
492 match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
493 match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
494 break;
495
496 case 't':
497 match ("target", gfc_match_target, ST_ATTR_DECL);
498 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
499 match ("type is", gfc_match_type_is, ST_TYPE_IS);
500 break;
501
502 case 'u':
503 match ("unlock", gfc_match_unlock, ST_UNLOCK);
504 break;
505
506 case 'v':
507 match ("value", gfc_match_value, ST_ATTR_DECL);
508 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
509 break;
510
511 case 'w':
512 match ("wait", gfc_match_wait, ST_WAIT);
513 match ("write", gfc_match_write, ST_WRITE);
514 break;
515 }
516
517 /* All else has failed, so give up. See if any of the matchers has
518 stored an error message of some sort. */
519
520 if (gfc_error_check () == 0)
521 gfc_error_now ("Unclassifiable statement at %C");
522
523 reject_statement ();
524
525 gfc_error_recovery ();
526
527 return ST_NONE;
528 }
529
530 static gfc_statement
531 decode_omp_directive (void)
532 {
533 locus old_locus;
534 char c;
535
536 gfc_enforce_clean_symbol_state ();
537
538 gfc_clear_error (); /* Clear any pending errors. */
539 gfc_clear_warning (); /* Clear any pending warnings. */
540
541 if (gfc_pure (NULL))
542 {
543 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
544 "or ELEMENTAL procedures");
545 gfc_error_recovery ();
546 return ST_NONE;
547 }
548
549 if (gfc_implicit_pure (NULL))
550 gfc_current_ns->proc_name->attr.implicit_pure = 0;
551
552 old_locus = gfc_current_locus;
553
554 /* General OpenMP directive matching: Instead of testing every possible
555 statement, we eliminate most possibilities by peeking at the
556 first character. */
557
558 c = gfc_peek_ascii_char ();
559
560 switch (c)
561 {
562 case 'a':
563 match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
564 break;
565 case 'b':
566 match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
567 break;
568 case 'c':
569 match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
570 break;
571 case 'd':
572 match ("do", gfc_match_omp_do, ST_OMP_DO);
573 break;
574 case 'e':
575 match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
576 match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
577 match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
578 match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
579 match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
580 match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
581 match ("end parallel sections", gfc_match_omp_eos,
582 ST_OMP_END_PARALLEL_SECTIONS);
583 match ("end parallel workshare", gfc_match_omp_eos,
584 ST_OMP_END_PARALLEL_WORKSHARE);
585 match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
586 match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
587 match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
588 match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
589 match ("end workshare", gfc_match_omp_end_nowait,
590 ST_OMP_END_WORKSHARE);
591 break;
592 case 'f':
593 match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
594 break;
595 case 'm':
596 match ("master", gfc_match_omp_master, ST_OMP_MASTER);
597 break;
598 case 'o':
599 match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
600 break;
601 case 'p':
602 match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
603 match ("parallel sections", gfc_match_omp_parallel_sections,
604 ST_OMP_PARALLEL_SECTIONS);
605 match ("parallel workshare", gfc_match_omp_parallel_workshare,
606 ST_OMP_PARALLEL_WORKSHARE);
607 match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
608 break;
609 case 's':
610 match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
611 match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
612 match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
613 break;
614 case 't':
615 match ("task", gfc_match_omp_task, ST_OMP_TASK);
616 match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
617 match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
618 match ("threadprivate", gfc_match_omp_threadprivate,
619 ST_OMP_THREADPRIVATE);
620 case 'w':
621 match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
622 break;
623 }
624
625 /* All else has failed, so give up. See if any of the matchers has
626 stored an error message of some sort. */
627
628 if (gfc_error_check () == 0)
629 gfc_error_now ("Unclassifiable OpenMP directive at %C");
630
631 reject_statement ();
632
633 gfc_error_recovery ();
634
635 return ST_NONE;
636 }
637
638 static gfc_statement
639 decode_gcc_attribute (void)
640 {
641 locus old_locus;
642
643 gfc_enforce_clean_symbol_state ();
644
645 gfc_clear_error (); /* Clear any pending errors. */
646 gfc_clear_warning (); /* Clear any pending warnings. */
647 old_locus = gfc_current_locus;
648
649 match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
650
651 /* All else has failed, so give up. See if any of the matchers has
652 stored an error message of some sort. */
653
654 if (gfc_error_check () == 0)
655 gfc_error_now ("Unclassifiable GCC directive at %C");
656
657 reject_statement ();
658
659 gfc_error_recovery ();
660
661 return ST_NONE;
662 }
663
664 #undef match
665
666
667 /* Get the next statement in free form source. */
668
669 static gfc_statement
670 next_free (void)
671 {
672 match m;
673 int i, cnt, at_bol;
674 char c;
675
676 at_bol = gfc_at_bol ();
677 gfc_gobble_whitespace ();
678
679 c = gfc_peek_ascii_char ();
680
681 if (ISDIGIT (c))
682 {
683 char d;
684
685 /* Found a statement label? */
686 m = gfc_match_st_label (&gfc_statement_label);
687
688 d = gfc_peek_ascii_char ();
689 if (m != MATCH_YES || !gfc_is_whitespace (d))
690 {
691 gfc_match_small_literal_int (&i, &cnt);
692
693 if (cnt > 5)
694 gfc_error_now ("Too many digits in statement label at %C");
695
696 if (i == 0)
697 gfc_error_now ("Zero is not a valid statement label at %C");
698
699 do
700 c = gfc_next_ascii_char ();
701 while (ISDIGIT(c));
702
703 if (!gfc_is_whitespace (c))
704 gfc_error_now ("Non-numeric character in statement label at %C");
705
706 return ST_NONE;
707 }
708 else
709 {
710 label_locus = gfc_current_locus;
711
712 gfc_gobble_whitespace ();
713
714 if (at_bol && gfc_peek_ascii_char () == ';')
715 {
716 gfc_error_now ("Semicolon at %C needs to be preceded by "
717 "statement");
718 gfc_next_ascii_char (); /* Eat up the semicolon. */
719 return ST_NONE;
720 }
721
722 if (gfc_match_eos () == MATCH_YES)
723 {
724 gfc_warning_now ("Ignoring statement label in empty statement "
725 "at %L", &label_locus);
726 gfc_free_st_label (gfc_statement_label);
727 gfc_statement_label = NULL;
728 return ST_NONE;
729 }
730 }
731 }
732 else if (c == '!')
733 {
734 /* Comments have already been skipped by the time we get here,
735 except for GCC attributes and OpenMP directives. */
736
737 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
738 c = gfc_peek_ascii_char ();
739
740 if (c == 'g')
741 {
742 int i;
743
744 c = gfc_next_ascii_char ();
745 for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
746 gcc_assert (c == "gcc$"[i]);
747
748 gfc_gobble_whitespace ();
749 return decode_gcc_attribute ();
750
751 }
752 else if (c == '$' && gfc_option.gfc_flag_openmp)
753 {
754 int i;
755
756 c = gfc_next_ascii_char ();
757 for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
758 gcc_assert (c == "$omp"[i]);
759
760 gcc_assert (c == ' ' || c == '\t');
761 gfc_gobble_whitespace ();
762 if (last_was_use_stmt)
763 use_modules ();
764 return decode_omp_directive ();
765 }
766
767 gcc_unreachable ();
768 }
769
770 if (at_bol && c == ';')
771 {
772 if (!(gfc_option.allow_std & GFC_STD_F2008))
773 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
774 "statement");
775 gfc_next_ascii_char (); /* Eat up the semicolon. */
776 return ST_NONE;
777 }
778
779 return decode_statement ();
780 }
781
782
783 /* Get the next statement in fixed-form source. */
784
785 static gfc_statement
786 next_fixed (void)
787 {
788 int label, digit_flag, i;
789 locus loc;
790 gfc_char_t c;
791
792 if (!gfc_at_bol ())
793 return decode_statement ();
794
795 /* Skip past the current label field, parsing a statement label if
796 one is there. This is a weird number parser, since the number is
797 contained within five columns and can have any kind of embedded
798 spaces. We also check for characters that make the rest of the
799 line a comment. */
800
801 label = 0;
802 digit_flag = 0;
803
804 for (i = 0; i < 5; i++)
805 {
806 c = gfc_next_char_literal (NONSTRING);
807
808 switch (c)
809 {
810 case ' ':
811 break;
812
813 case '0':
814 case '1':
815 case '2':
816 case '3':
817 case '4':
818 case '5':
819 case '6':
820 case '7':
821 case '8':
822 case '9':
823 label = label * 10 + ((unsigned char) c - '0');
824 label_locus = gfc_current_locus;
825 digit_flag = 1;
826 break;
827
828 /* Comments have already been skipped by the time we get
829 here, except for GCC attributes and OpenMP directives. */
830
831 case '*':
832 c = gfc_next_char_literal (NONSTRING);
833
834 if (TOLOWER (c) == 'g')
835 {
836 for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
837 gcc_assert (TOLOWER (c) == "gcc$"[i]);
838
839 return decode_gcc_attribute ();
840 }
841 else if (c == '$' && gfc_option.gfc_flag_openmp)
842 {
843 for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
844 gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
845
846 if (c != ' ' && c != '0')
847 {
848 gfc_buffer_error (0);
849 gfc_error ("Bad continuation line at %C");
850 return ST_NONE;
851 }
852 if (last_was_use_stmt)
853 use_modules ();
854 return decode_omp_directive ();
855 }
856 /* FALLTHROUGH */
857
858 /* Comments have already been skipped by the time we get
859 here so don't bother checking for them. */
860
861 default:
862 gfc_buffer_error (0);
863 gfc_error ("Non-numeric character in statement label at %C");
864 return ST_NONE;
865 }
866 }
867
868 if (digit_flag)
869 {
870 if (label == 0)
871 gfc_warning_now ("Zero is not a valid statement label at %C");
872 else
873 {
874 /* We've found a valid statement label. */
875 gfc_statement_label = gfc_get_st_label (label);
876 }
877 }
878
879 /* Since this line starts a statement, it cannot be a continuation
880 of a previous statement. If we see something here besides a
881 space or zero, it must be a bad continuation line. */
882
883 c = gfc_next_char_literal (NONSTRING);
884 if (c == '\n')
885 goto blank_line;
886
887 if (c != ' ' && c != '0')
888 {
889 gfc_buffer_error (0);
890 gfc_error ("Bad continuation line at %C");
891 return ST_NONE;
892 }
893
894 /* Now that we've taken care of the statement label columns, we have
895 to make sure that the first nonblank character is not a '!'. If
896 it is, the rest of the line is a comment. */
897
898 do
899 {
900 loc = gfc_current_locus;
901 c = gfc_next_char_literal (NONSTRING);
902 }
903 while (gfc_is_whitespace (c));
904
905 if (c == '!')
906 goto blank_line;
907 gfc_current_locus = loc;
908
909 if (c == ';')
910 {
911 if (digit_flag)
912 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
913 else if (!(gfc_option.allow_std & GFC_STD_F2008))
914 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
915 "statement");
916 return ST_NONE;
917 }
918
919 if (gfc_match_eos () == MATCH_YES)
920 goto blank_line;
921
922 /* At this point, we've got a nonblank statement to parse. */
923 return decode_statement ();
924
925 blank_line:
926 if (digit_flag)
927 gfc_warning_now ("Ignoring statement label in empty statement at %L",
928 &label_locus);
929
930 gfc_current_locus.lb->truncated = 0;
931 gfc_advance_line ();
932 return ST_NONE;
933 }
934
935
936 /* Return the next non-ST_NONE statement to the caller. We also worry
937 about including files and the ends of include files at this stage. */
938
939 static gfc_statement
940 next_statement (void)
941 {
942 gfc_statement st;
943 locus old_locus;
944
945 gfc_enforce_clean_symbol_state ();
946
947 gfc_new_block = NULL;
948
949 gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
950 gfc_current_ns->old_equiv = gfc_current_ns->equiv;
951 for (;;)
952 {
953 gfc_statement_label = NULL;
954 gfc_buffer_error (1);
955
956 if (gfc_at_eol ())
957 gfc_advance_line ();
958
959 gfc_skip_comments ();
960
961 if (gfc_at_end ())
962 {
963 st = ST_NONE;
964 break;
965 }
966
967 if (gfc_define_undef_line ())
968 continue;
969
970 old_locus = gfc_current_locus;
971
972 st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
973
974 if (st != ST_NONE)
975 break;
976 }
977
978 gfc_buffer_error (0);
979
980 if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
981 {
982 gfc_free_st_label (gfc_statement_label);
983 gfc_statement_label = NULL;
984 gfc_current_locus = old_locus;
985 }
986
987 if (st != ST_NONE)
988 check_statement_label (st);
989
990 return st;
991 }
992
993
994 /****************************** Parser ***********************************/
995
996 /* The parser subroutines are of type 'try' that fail if the file ends
997 unexpectedly. */
998
999 /* Macros that expand to case-labels for various classes of
1000 statements. Start with executable statements that directly do
1001 things. */
1002
1003 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1004 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1005 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1006 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1007 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1008 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1009 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1010 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1011 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1012 case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
1013 case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
1014
1015 /* Statements that mark other executable statements. */
1016
1017 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1018 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1019 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1020 case ST_OMP_PARALLEL: \
1021 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1022 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1023 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1024 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1025 case ST_OMP_TASK: case ST_CRITICAL
1026
1027 /* Declaration statements */
1028
1029 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1030 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1031 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1032 case ST_PROCEDURE
1033
1034 /* Block end statements. Errors associated with interchanging these
1035 are detected in gfc_match_end(). */
1036
1037 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1038 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1039 case ST_END_BLOCK: case ST_END_ASSOCIATE
1040
1041
1042 /* Push a new state onto the stack. */
1043
1044 static void
1045 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
1046 {
1047 p->state = new_state;
1048 p->previous = gfc_state_stack;
1049 p->sym = sym;
1050 p->head = p->tail = NULL;
1051 p->do_variable = NULL;
1052
1053 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1054 construct statement was accepted right before pushing the state. Thus,
1055 the construct's gfc_code is available as tail of the parent state. */
1056 gcc_assert (gfc_state_stack);
1057 p->construct = gfc_state_stack->tail;
1058
1059 gfc_state_stack = p;
1060 }
1061
1062
1063 /* Pop the current state. */
1064 static void
1065 pop_state (void)
1066 {
1067 gfc_state_stack = gfc_state_stack->previous;
1068 }
1069
1070
1071 /* Try to find the given state in the state stack. */
1072
1073 gfc_try
1074 gfc_find_state (gfc_compile_state state)
1075 {
1076 gfc_state_data *p;
1077
1078 for (p = gfc_state_stack; p; p = p->previous)
1079 if (p->state == state)
1080 break;
1081
1082 return (p == NULL) ? FAILURE : SUCCESS;
1083 }
1084
1085
1086 /* Starts a new level in the statement list. */
1087
1088 static gfc_code *
1089 new_level (gfc_code *q)
1090 {
1091 gfc_code *p;
1092
1093 p = q->block = gfc_get_code ();
1094
1095 gfc_state_stack->head = gfc_state_stack->tail = p;
1096
1097 return p;
1098 }
1099
1100
1101 /* Add the current new_st code structure and adds it to the current
1102 program unit. As a side-effect, it zeroes the new_st. */
1103
1104 static gfc_code *
1105 add_statement (void)
1106 {
1107 gfc_code *p;
1108
1109 p = gfc_get_code ();
1110 *p = new_st;
1111
1112 p->loc = gfc_current_locus;
1113
1114 if (gfc_state_stack->head == NULL)
1115 gfc_state_stack->head = p;
1116 else
1117 gfc_state_stack->tail->next = p;
1118
1119 while (p->next != NULL)
1120 p = p->next;
1121
1122 gfc_state_stack->tail = p;
1123
1124 gfc_clear_new_st ();
1125
1126 return p;
1127 }
1128
1129
1130 /* Frees everything associated with the current statement. */
1131
1132 static void
1133 undo_new_statement (void)
1134 {
1135 gfc_free_statements (new_st.block);
1136 gfc_free_statements (new_st.next);
1137 gfc_free_statement (&new_st);
1138 gfc_clear_new_st ();
1139 }
1140
1141
1142 /* If the current statement has a statement label, make sure that it
1143 is allowed to, or should have one. */
1144
1145 static void
1146 check_statement_label (gfc_statement st)
1147 {
1148 gfc_sl_type type;
1149
1150 if (gfc_statement_label == NULL)
1151 {
1152 if (st == ST_FORMAT)
1153 gfc_error ("FORMAT statement at %L does not have a statement label",
1154 &new_st.loc);
1155 return;
1156 }
1157
1158 switch (st)
1159 {
1160 case ST_END_PROGRAM:
1161 case ST_END_FUNCTION:
1162 case ST_END_SUBROUTINE:
1163 case ST_ENDDO:
1164 case ST_ENDIF:
1165 case ST_END_SELECT:
1166 case ST_END_CRITICAL:
1167 case ST_END_BLOCK:
1168 case ST_END_ASSOCIATE:
1169 case_executable:
1170 case_exec_markers:
1171 if (st == ST_ENDDO || st == ST_CONTINUE)
1172 type = ST_LABEL_DO_TARGET;
1173 else
1174 type = ST_LABEL_TARGET;
1175 break;
1176
1177 case ST_FORMAT:
1178 type = ST_LABEL_FORMAT;
1179 break;
1180
1181 /* Statement labels are not restricted from appearing on a
1182 particular line. However, there are plenty of situations
1183 where the resulting label can't be referenced. */
1184
1185 default:
1186 type = ST_LABEL_BAD_TARGET;
1187 break;
1188 }
1189
1190 gfc_define_st_label (gfc_statement_label, type, &label_locus);
1191
1192 new_st.here = gfc_statement_label;
1193 }
1194
1195
1196 /* Figures out what the enclosing program unit is. This will be a
1197 function, subroutine, program, block data or module. */
1198
1199 gfc_state_data *
1200 gfc_enclosing_unit (gfc_compile_state * result)
1201 {
1202 gfc_state_data *p;
1203
1204 for (p = gfc_state_stack; p; p = p->previous)
1205 if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1206 || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1207 || p->state == COMP_PROGRAM)
1208 {
1209
1210 if (result != NULL)
1211 *result = p->state;
1212 return p;
1213 }
1214
1215 if (result != NULL)
1216 *result = COMP_PROGRAM;
1217 return NULL;
1218 }
1219
1220
1221 /* Translate a statement enum to a string. */
1222
1223 const char *
1224 gfc_ascii_statement (gfc_statement st)
1225 {
1226 const char *p;
1227
1228 switch (st)
1229 {
1230 case ST_ARITHMETIC_IF:
1231 p = _("arithmetic IF");
1232 break;
1233 case ST_ALLOCATE:
1234 p = "ALLOCATE";
1235 break;
1236 case ST_ASSOCIATE:
1237 p = "ASSOCIATE";
1238 break;
1239 case ST_ATTR_DECL:
1240 p = _("attribute declaration");
1241 break;
1242 case ST_BACKSPACE:
1243 p = "BACKSPACE";
1244 break;
1245 case ST_BLOCK:
1246 p = "BLOCK";
1247 break;
1248 case ST_BLOCK_DATA:
1249 p = "BLOCK DATA";
1250 break;
1251 case ST_CALL:
1252 p = "CALL";
1253 break;
1254 case ST_CASE:
1255 p = "CASE";
1256 break;
1257 case ST_CLOSE:
1258 p = "CLOSE";
1259 break;
1260 case ST_COMMON:
1261 p = "COMMON";
1262 break;
1263 case ST_CONTINUE:
1264 p = "CONTINUE";
1265 break;
1266 case ST_CONTAINS:
1267 p = "CONTAINS";
1268 break;
1269 case ST_CRITICAL:
1270 p = "CRITICAL";
1271 break;
1272 case ST_CYCLE:
1273 p = "CYCLE";
1274 break;
1275 case ST_DATA_DECL:
1276 p = _("data declaration");
1277 break;
1278 case ST_DATA:
1279 p = "DATA";
1280 break;
1281 case ST_DEALLOCATE:
1282 p = "DEALLOCATE";
1283 break;
1284 case ST_DERIVED_DECL:
1285 p = _("derived type declaration");
1286 break;
1287 case ST_DO:
1288 p = "DO";
1289 break;
1290 case ST_ELSE:
1291 p = "ELSE";
1292 break;
1293 case ST_ELSEIF:
1294 p = "ELSE IF";
1295 break;
1296 case ST_ELSEWHERE:
1297 p = "ELSEWHERE";
1298 break;
1299 case ST_END_ASSOCIATE:
1300 p = "END ASSOCIATE";
1301 break;
1302 case ST_END_BLOCK:
1303 p = "END BLOCK";
1304 break;
1305 case ST_END_BLOCK_DATA:
1306 p = "END BLOCK DATA";
1307 break;
1308 case ST_END_CRITICAL:
1309 p = "END CRITICAL";
1310 break;
1311 case ST_ENDDO:
1312 p = "END DO";
1313 break;
1314 case ST_END_FILE:
1315 p = "END FILE";
1316 break;
1317 case ST_END_FORALL:
1318 p = "END FORALL";
1319 break;
1320 case ST_END_FUNCTION:
1321 p = "END FUNCTION";
1322 break;
1323 case ST_ENDIF:
1324 p = "END IF";
1325 break;
1326 case ST_END_INTERFACE:
1327 p = "END INTERFACE";
1328 break;
1329 case ST_END_MODULE:
1330 p = "END MODULE";
1331 break;
1332 case ST_END_PROGRAM:
1333 p = "END PROGRAM";
1334 break;
1335 case ST_END_SELECT:
1336 p = "END SELECT";
1337 break;
1338 case ST_END_SUBROUTINE:
1339 p = "END SUBROUTINE";
1340 break;
1341 case ST_END_WHERE:
1342 p = "END WHERE";
1343 break;
1344 case ST_END_TYPE:
1345 p = "END TYPE";
1346 break;
1347 case ST_ENTRY:
1348 p = "ENTRY";
1349 break;
1350 case ST_EQUIVALENCE:
1351 p = "EQUIVALENCE";
1352 break;
1353 case ST_ERROR_STOP:
1354 p = "ERROR STOP";
1355 break;
1356 case ST_EXIT:
1357 p = "EXIT";
1358 break;
1359 case ST_FLUSH:
1360 p = "FLUSH";
1361 break;
1362 case ST_FORALL_BLOCK: /* Fall through */
1363 case ST_FORALL:
1364 p = "FORALL";
1365 break;
1366 case ST_FORMAT:
1367 p = "FORMAT";
1368 break;
1369 case ST_FUNCTION:
1370 p = "FUNCTION";
1371 break;
1372 case ST_GENERIC:
1373 p = "GENERIC";
1374 break;
1375 case ST_GOTO:
1376 p = "GOTO";
1377 break;
1378 case ST_IF_BLOCK:
1379 p = _("block IF");
1380 break;
1381 case ST_IMPLICIT:
1382 p = "IMPLICIT";
1383 break;
1384 case ST_IMPLICIT_NONE:
1385 p = "IMPLICIT NONE";
1386 break;
1387 case ST_IMPLIED_ENDDO:
1388 p = _("implied END DO");
1389 break;
1390 case ST_IMPORT:
1391 p = "IMPORT";
1392 break;
1393 case ST_INQUIRE:
1394 p = "INQUIRE";
1395 break;
1396 case ST_INTERFACE:
1397 p = "INTERFACE";
1398 break;
1399 case ST_LOCK:
1400 p = "LOCK";
1401 break;
1402 case ST_PARAMETER:
1403 p = "PARAMETER";
1404 break;
1405 case ST_PRIVATE:
1406 p = "PRIVATE";
1407 break;
1408 case ST_PUBLIC:
1409 p = "PUBLIC";
1410 break;
1411 case ST_MODULE:
1412 p = "MODULE";
1413 break;
1414 case ST_PAUSE:
1415 p = "PAUSE";
1416 break;
1417 case ST_MODULE_PROC:
1418 p = "MODULE PROCEDURE";
1419 break;
1420 case ST_NAMELIST:
1421 p = "NAMELIST";
1422 break;
1423 case ST_NULLIFY:
1424 p = "NULLIFY";
1425 break;
1426 case ST_OPEN:
1427 p = "OPEN";
1428 break;
1429 case ST_PROGRAM:
1430 p = "PROGRAM";
1431 break;
1432 case ST_PROCEDURE:
1433 p = "PROCEDURE";
1434 break;
1435 case ST_READ:
1436 p = "READ";
1437 break;
1438 case ST_RETURN:
1439 p = "RETURN";
1440 break;
1441 case ST_REWIND:
1442 p = "REWIND";
1443 break;
1444 case ST_STOP:
1445 p = "STOP";
1446 break;
1447 case ST_SYNC_ALL:
1448 p = "SYNC ALL";
1449 break;
1450 case ST_SYNC_IMAGES:
1451 p = "SYNC IMAGES";
1452 break;
1453 case ST_SYNC_MEMORY:
1454 p = "SYNC MEMORY";
1455 break;
1456 case ST_SUBROUTINE:
1457 p = "SUBROUTINE";
1458 break;
1459 case ST_TYPE:
1460 p = "TYPE";
1461 break;
1462 case ST_UNLOCK:
1463 p = "UNLOCK";
1464 break;
1465 case ST_USE:
1466 p = "USE";
1467 break;
1468 case ST_WHERE_BLOCK: /* Fall through */
1469 case ST_WHERE:
1470 p = "WHERE";
1471 break;
1472 case ST_WAIT:
1473 p = "WAIT";
1474 break;
1475 case ST_WRITE:
1476 p = "WRITE";
1477 break;
1478 case ST_ASSIGNMENT:
1479 p = _("assignment");
1480 break;
1481 case ST_POINTER_ASSIGNMENT:
1482 p = _("pointer assignment");
1483 break;
1484 case ST_SELECT_CASE:
1485 p = "SELECT CASE";
1486 break;
1487 case ST_SELECT_TYPE:
1488 p = "SELECT TYPE";
1489 break;
1490 case ST_TYPE_IS:
1491 p = "TYPE IS";
1492 break;
1493 case ST_CLASS_IS:
1494 p = "CLASS IS";
1495 break;
1496 case ST_SEQUENCE:
1497 p = "SEQUENCE";
1498 break;
1499 case ST_SIMPLE_IF:
1500 p = _("simple IF");
1501 break;
1502 case ST_STATEMENT_FUNCTION:
1503 p = "STATEMENT FUNCTION";
1504 break;
1505 case ST_LABEL_ASSIGNMENT:
1506 p = "LABEL ASSIGNMENT";
1507 break;
1508 case ST_ENUM:
1509 p = "ENUM DEFINITION";
1510 break;
1511 case ST_ENUMERATOR:
1512 p = "ENUMERATOR DEFINITION";
1513 break;
1514 case ST_END_ENUM:
1515 p = "END ENUM";
1516 break;
1517 case ST_OMP_ATOMIC:
1518 p = "!$OMP ATOMIC";
1519 break;
1520 case ST_OMP_BARRIER:
1521 p = "!$OMP BARRIER";
1522 break;
1523 case ST_OMP_CRITICAL:
1524 p = "!$OMP CRITICAL";
1525 break;
1526 case ST_OMP_DO:
1527 p = "!$OMP DO";
1528 break;
1529 case ST_OMP_END_ATOMIC:
1530 p = "!$OMP END ATOMIC";
1531 break;
1532 case ST_OMP_END_CRITICAL:
1533 p = "!$OMP END CRITICAL";
1534 break;
1535 case ST_OMP_END_DO:
1536 p = "!$OMP END DO";
1537 break;
1538 case ST_OMP_END_MASTER:
1539 p = "!$OMP END MASTER";
1540 break;
1541 case ST_OMP_END_ORDERED:
1542 p = "!$OMP END ORDERED";
1543 break;
1544 case ST_OMP_END_PARALLEL:
1545 p = "!$OMP END PARALLEL";
1546 break;
1547 case ST_OMP_END_PARALLEL_DO:
1548 p = "!$OMP END PARALLEL DO";
1549 break;
1550 case ST_OMP_END_PARALLEL_SECTIONS:
1551 p = "!$OMP END PARALLEL SECTIONS";
1552 break;
1553 case ST_OMP_END_PARALLEL_WORKSHARE:
1554 p = "!$OMP END PARALLEL WORKSHARE";
1555 break;
1556 case ST_OMP_END_SECTIONS:
1557 p = "!$OMP END SECTIONS";
1558 break;
1559 case ST_OMP_END_SINGLE:
1560 p = "!$OMP END SINGLE";
1561 break;
1562 case ST_OMP_END_TASK:
1563 p = "!$OMP END TASK";
1564 break;
1565 case ST_OMP_END_WORKSHARE:
1566 p = "!$OMP END WORKSHARE";
1567 break;
1568 case ST_OMP_FLUSH:
1569 p = "!$OMP FLUSH";
1570 break;
1571 case ST_OMP_MASTER:
1572 p = "!$OMP MASTER";
1573 break;
1574 case ST_OMP_ORDERED:
1575 p = "!$OMP ORDERED";
1576 break;
1577 case ST_OMP_PARALLEL:
1578 p = "!$OMP PARALLEL";
1579 break;
1580 case ST_OMP_PARALLEL_DO:
1581 p = "!$OMP PARALLEL DO";
1582 break;
1583 case ST_OMP_PARALLEL_SECTIONS:
1584 p = "!$OMP PARALLEL SECTIONS";
1585 break;
1586 case ST_OMP_PARALLEL_WORKSHARE:
1587 p = "!$OMP PARALLEL WORKSHARE";
1588 break;
1589 case ST_OMP_SECTIONS:
1590 p = "!$OMP SECTIONS";
1591 break;
1592 case ST_OMP_SECTION:
1593 p = "!$OMP SECTION";
1594 break;
1595 case ST_OMP_SINGLE:
1596 p = "!$OMP SINGLE";
1597 break;
1598 case ST_OMP_TASK:
1599 p = "!$OMP TASK";
1600 break;
1601 case ST_OMP_TASKWAIT:
1602 p = "!$OMP TASKWAIT";
1603 break;
1604 case ST_OMP_TASKYIELD:
1605 p = "!$OMP TASKYIELD";
1606 break;
1607 case ST_OMP_THREADPRIVATE:
1608 p = "!$OMP THREADPRIVATE";
1609 break;
1610 case ST_OMP_WORKSHARE:
1611 p = "!$OMP WORKSHARE";
1612 break;
1613 default:
1614 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1615 }
1616
1617 return p;
1618 }
1619
1620
1621 /* Create a symbol for the main program and assign it to ns->proc_name. */
1622
1623 static void
1624 main_program_symbol (gfc_namespace *ns, const char *name)
1625 {
1626 gfc_symbol *main_program;
1627 symbol_attribute attr;
1628
1629 gfc_get_symbol (name, ns, &main_program);
1630 gfc_clear_attr (&attr);
1631 attr.flavor = FL_PROGRAM;
1632 attr.proc = PROC_UNKNOWN;
1633 attr.subroutine = 1;
1634 attr.access = ACCESS_PUBLIC;
1635 attr.is_main_program = 1;
1636 main_program->attr = attr;
1637 main_program->declared_at = gfc_current_locus;
1638 ns->proc_name = main_program;
1639 gfc_commit_symbols ();
1640 }
1641
1642
1643 /* Do whatever is necessary to accept the last statement. */
1644
1645 static void
1646 accept_statement (gfc_statement st)
1647 {
1648 switch (st)
1649 {
1650 case ST_IMPLICIT_NONE:
1651 gfc_set_implicit_none ();
1652 break;
1653
1654 case ST_IMPLICIT:
1655 break;
1656
1657 case ST_FUNCTION:
1658 case ST_SUBROUTINE:
1659 case ST_MODULE:
1660 gfc_current_ns->proc_name = gfc_new_block;
1661 break;
1662
1663 /* If the statement is the end of a block, lay down a special code
1664 that allows a branch to the end of the block from within the
1665 construct. IF and SELECT are treated differently from DO
1666 (where EXEC_NOP is added inside the loop) for two
1667 reasons:
1668 1. END DO has a meaning in the sense that after a GOTO to
1669 it, the loop counter must be increased.
1670 2. IF blocks and SELECT blocks can consist of multiple
1671 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1672 Putting the label before the END IF would make the jump
1673 from, say, the ELSE IF block to the END IF illegal. */
1674
1675 case ST_ENDIF:
1676 case ST_END_SELECT:
1677 case ST_END_CRITICAL:
1678 if (gfc_statement_label != NULL)
1679 {
1680 new_st.op = EXEC_END_NESTED_BLOCK;
1681 add_statement ();
1682 }
1683 break;
1684
1685 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
1686 one parallel block. Thus, we add the special code to the nested block
1687 itself, instead of the parent one. */
1688 case ST_END_BLOCK:
1689 case ST_END_ASSOCIATE:
1690 if (gfc_statement_label != NULL)
1691 {
1692 new_st.op = EXEC_END_BLOCK;
1693 add_statement ();
1694 }
1695 break;
1696
1697 /* The end-of-program unit statements do not get the special
1698 marker and require a statement of some sort if they are a
1699 branch target. */
1700
1701 case ST_END_PROGRAM:
1702 case ST_END_FUNCTION:
1703 case ST_END_SUBROUTINE:
1704 if (gfc_statement_label != NULL)
1705 {
1706 new_st.op = EXEC_RETURN;
1707 add_statement ();
1708 }
1709 else
1710 {
1711 new_st.op = EXEC_END_PROCEDURE;
1712 add_statement ();
1713 }
1714
1715 break;
1716
1717 case ST_ENTRY:
1718 case_executable:
1719 case_exec_markers:
1720 add_statement ();
1721 break;
1722
1723 default:
1724 break;
1725 }
1726
1727 gfc_commit_symbols ();
1728 gfc_warning_check ();
1729 gfc_clear_new_st ();
1730 }
1731
1732
1733 /* Undo anything tentative that has been built for the current
1734 statement. */
1735
1736 static void
1737 reject_statement (void)
1738 {
1739 /* Revert to the previous charlen chain. */
1740 gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
1741 gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
1742
1743 gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
1744 gfc_current_ns->equiv = gfc_current_ns->old_equiv;
1745
1746 gfc_new_block = NULL;
1747 gfc_undo_symbols ();
1748 gfc_clear_warning ();
1749 undo_new_statement ();
1750 }
1751
1752
1753 /* Generic complaint about an out of order statement. We also do
1754 whatever is necessary to clean up. */
1755
1756 static void
1757 unexpected_statement (gfc_statement st)
1758 {
1759 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1760
1761 reject_statement ();
1762 }
1763
1764
1765 /* Given the next statement seen by the matcher, make sure that it is
1766 in proper order with the last. This subroutine is initialized by
1767 calling it with an argument of ST_NONE. If there is a problem, we
1768 issue an error and return FAILURE. Otherwise we return SUCCESS.
1769
1770 Individual parsers need to verify that the statements seen are
1771 valid before calling here, i.e., ENTRY statements are not allowed in
1772 INTERFACE blocks. The following diagram is taken from the standard:
1773
1774 +---------------------------------------+
1775 | program subroutine function module |
1776 +---------------------------------------+
1777 | use |
1778 +---------------------------------------+
1779 | import |
1780 +---------------------------------------+
1781 | | implicit none |
1782 | +-----------+------------------+
1783 | | parameter | implicit |
1784 | +-----------+------------------+
1785 | format | | derived type |
1786 | entry | parameter | interface |
1787 | | data | specification |
1788 | | | statement func |
1789 | +-----------+------------------+
1790 | | data | executable |
1791 +--------+-----------+------------------+
1792 | contains |
1793 +---------------------------------------+
1794 | internal module/subprogram |
1795 +---------------------------------------+
1796 | end |
1797 +---------------------------------------+
1798
1799 */
1800
1801 enum state_order
1802 {
1803 ORDER_START,
1804 ORDER_USE,
1805 ORDER_IMPORT,
1806 ORDER_IMPLICIT_NONE,
1807 ORDER_IMPLICIT,
1808 ORDER_SPEC,
1809 ORDER_EXEC
1810 };
1811
1812 typedef struct
1813 {
1814 enum state_order state;
1815 gfc_statement last_statement;
1816 locus where;
1817 }
1818 st_state;
1819
1820 static gfc_try
1821 verify_st_order (st_state *p, gfc_statement st, bool silent)
1822 {
1823
1824 switch (st)
1825 {
1826 case ST_NONE:
1827 p->state = ORDER_START;
1828 break;
1829
1830 case ST_USE:
1831 if (p->state > ORDER_USE)
1832 goto order;
1833 p->state = ORDER_USE;
1834 break;
1835
1836 case ST_IMPORT:
1837 if (p->state > ORDER_IMPORT)
1838 goto order;
1839 p->state = ORDER_IMPORT;
1840 break;
1841
1842 case ST_IMPLICIT_NONE:
1843 if (p->state > ORDER_IMPLICIT_NONE)
1844 goto order;
1845
1846 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1847 statement disqualifies a USE but not an IMPLICIT NONE.
1848 Duplicate IMPLICIT NONEs are caught when the implicit types
1849 are set. */
1850
1851 p->state = ORDER_IMPLICIT_NONE;
1852 break;
1853
1854 case ST_IMPLICIT:
1855 if (p->state > ORDER_IMPLICIT)
1856 goto order;
1857 p->state = ORDER_IMPLICIT;
1858 break;
1859
1860 case ST_FORMAT:
1861 case ST_ENTRY:
1862 if (p->state < ORDER_IMPLICIT_NONE)
1863 p->state = ORDER_IMPLICIT_NONE;
1864 break;
1865
1866 case ST_PARAMETER:
1867 if (p->state >= ORDER_EXEC)
1868 goto order;
1869 if (p->state < ORDER_IMPLICIT)
1870 p->state = ORDER_IMPLICIT;
1871 break;
1872
1873 case ST_DATA:
1874 if (p->state < ORDER_SPEC)
1875 p->state = ORDER_SPEC;
1876 break;
1877
1878 case ST_PUBLIC:
1879 case ST_PRIVATE:
1880 case ST_DERIVED_DECL:
1881 case_decl:
1882 if (p->state >= ORDER_EXEC)
1883 goto order;
1884 if (p->state < ORDER_SPEC)
1885 p->state = ORDER_SPEC;
1886 break;
1887
1888 case_executable:
1889 case_exec_markers:
1890 if (p->state < ORDER_EXEC)
1891 p->state = ORDER_EXEC;
1892 break;
1893
1894 default:
1895 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1896 gfc_ascii_statement (st));
1897 }
1898
1899 /* All is well, record the statement in case we need it next time. */
1900 p->where = gfc_current_locus;
1901 p->last_statement = st;
1902 return SUCCESS;
1903
1904 order:
1905 if (!silent)
1906 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1907 gfc_ascii_statement (st),
1908 gfc_ascii_statement (p->last_statement), &p->where);
1909
1910 return FAILURE;
1911 }
1912
1913
1914 /* Handle an unexpected end of file. This is a show-stopper... */
1915
1916 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1917
1918 static void
1919 unexpected_eof (void)
1920 {
1921 gfc_state_data *p;
1922
1923 gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1924
1925 /* Memory cleanup. Move to "second to last". */
1926 for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1927 p = p->previous);
1928
1929 gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1930 gfc_done_2 ();
1931
1932 longjmp (eof_buf, 1);
1933 }
1934
1935
1936 /* Parse the CONTAINS section of a derived type definition. */
1937
1938 gfc_access gfc_typebound_default_access;
1939
1940 static bool
1941 parse_derived_contains (void)
1942 {
1943 gfc_state_data s;
1944 bool seen_private = false;
1945 bool seen_comps = false;
1946 bool error_flag = false;
1947 bool to_finish;
1948
1949 gcc_assert (gfc_current_state () == COMP_DERIVED);
1950 gcc_assert (gfc_current_block ());
1951
1952 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1953 section. */
1954 if (gfc_current_block ()->attr.sequence)
1955 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1956 " section at %C", gfc_current_block ()->name);
1957 if (gfc_current_block ()->attr.is_bind_c)
1958 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1959 " section at %C", gfc_current_block ()->name);
1960
1961 accept_statement (ST_CONTAINS);
1962 push_state (&s, COMP_DERIVED_CONTAINS, NULL);
1963
1964 gfc_typebound_default_access = ACCESS_PUBLIC;
1965
1966 to_finish = false;
1967 while (!to_finish)
1968 {
1969 gfc_statement st;
1970 st = next_statement ();
1971 switch (st)
1972 {
1973 case ST_NONE:
1974 unexpected_eof ();
1975 break;
1976
1977 case ST_DATA_DECL:
1978 gfc_error ("Components in TYPE at %C must precede CONTAINS");
1979 goto error;
1980
1981 case ST_PROCEDURE:
1982 if (gfc_notify_std (GFC_STD_F2003, "Type-bound"
1983 " procedure at %C") == FAILURE)
1984 goto error;
1985
1986 accept_statement (ST_PROCEDURE);
1987 seen_comps = true;
1988 break;
1989
1990 case ST_GENERIC:
1991 if (gfc_notify_std (GFC_STD_F2003, "GENERIC binding"
1992 " at %C") == FAILURE)
1993 goto error;
1994
1995 accept_statement (ST_GENERIC);
1996 seen_comps = true;
1997 break;
1998
1999 case ST_FINAL:
2000 if (gfc_notify_std (GFC_STD_F2003,
2001 "FINAL procedure declaration"
2002 " at %C") == FAILURE)
2003 goto error;
2004
2005 accept_statement (ST_FINAL);
2006 seen_comps = true;
2007 break;
2008
2009 case ST_END_TYPE:
2010 to_finish = true;
2011
2012 if (!seen_comps
2013 && (gfc_notify_std (GFC_STD_F2008, "Derived type "
2014 "definition at %C with empty CONTAINS "
2015 "section") == FAILURE))
2016 goto error;
2017
2018 /* ST_END_TYPE is accepted by parse_derived after return. */
2019 break;
2020
2021 case ST_PRIVATE:
2022 if (gfc_find_state (COMP_MODULE) == FAILURE)
2023 {
2024 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2025 "a MODULE");
2026 goto error;
2027 }
2028
2029 if (seen_comps)
2030 {
2031 gfc_error ("PRIVATE statement at %C must precede procedure"
2032 " bindings");
2033 goto error;
2034 }
2035
2036 if (seen_private)
2037 {
2038 gfc_error ("Duplicate PRIVATE statement at %C");
2039 goto error;
2040 }
2041
2042 accept_statement (ST_PRIVATE);
2043 gfc_typebound_default_access = ACCESS_PRIVATE;
2044 seen_private = true;
2045 break;
2046
2047 case ST_SEQUENCE:
2048 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2049 goto error;
2050
2051 case ST_CONTAINS:
2052 gfc_error ("Already inside a CONTAINS block at %C");
2053 goto error;
2054
2055 default:
2056 unexpected_statement (st);
2057 break;
2058 }
2059
2060 continue;
2061
2062 error:
2063 error_flag = true;
2064 reject_statement ();
2065 }
2066
2067 pop_state ();
2068 gcc_assert (gfc_current_state () == COMP_DERIVED);
2069
2070 return error_flag;
2071 }
2072
2073
2074 /* Parse a derived type. */
2075
2076 static void
2077 parse_derived (void)
2078 {
2079 int compiling_type, seen_private, seen_sequence, seen_component;
2080 gfc_statement st;
2081 gfc_state_data s;
2082 gfc_symbol *sym;
2083 gfc_component *c, *lock_comp = NULL;
2084
2085 accept_statement (ST_DERIVED_DECL);
2086 push_state (&s, COMP_DERIVED, gfc_new_block);
2087
2088 gfc_new_block->component_access = ACCESS_PUBLIC;
2089 seen_private = 0;
2090 seen_sequence = 0;
2091 seen_component = 0;
2092
2093 compiling_type = 1;
2094
2095 while (compiling_type)
2096 {
2097 st = next_statement ();
2098 switch (st)
2099 {
2100 case ST_NONE:
2101 unexpected_eof ();
2102
2103 case ST_DATA_DECL:
2104 case ST_PROCEDURE:
2105 accept_statement (st);
2106 seen_component = 1;
2107 break;
2108
2109 case ST_FINAL:
2110 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2111 break;
2112
2113 case ST_END_TYPE:
2114 endType:
2115 compiling_type = 0;
2116
2117 if (!seen_component)
2118 gfc_notify_std (GFC_STD_F2003, "Derived type "
2119 "definition at %C without components");
2120
2121 accept_statement (ST_END_TYPE);
2122 break;
2123
2124 case ST_PRIVATE:
2125 if (gfc_find_state (COMP_MODULE) == FAILURE)
2126 {
2127 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2128 "a MODULE");
2129 break;
2130 }
2131
2132 if (seen_component)
2133 {
2134 gfc_error ("PRIVATE statement at %C must precede "
2135 "structure components");
2136 break;
2137 }
2138
2139 if (seen_private)
2140 gfc_error ("Duplicate PRIVATE statement at %C");
2141
2142 s.sym->component_access = ACCESS_PRIVATE;
2143
2144 accept_statement (ST_PRIVATE);
2145 seen_private = 1;
2146 break;
2147
2148 case ST_SEQUENCE:
2149 if (seen_component)
2150 {
2151 gfc_error ("SEQUENCE statement at %C must precede "
2152 "structure components");
2153 break;
2154 }
2155
2156 if (gfc_current_block ()->attr.sequence)
2157 gfc_warning ("SEQUENCE attribute at %C already specified in "
2158 "TYPE statement");
2159
2160 if (seen_sequence)
2161 {
2162 gfc_error ("Duplicate SEQUENCE statement at %C");
2163 }
2164
2165 seen_sequence = 1;
2166 gfc_add_sequence (&gfc_current_block ()->attr,
2167 gfc_current_block ()->name, NULL);
2168 break;
2169
2170 case ST_CONTAINS:
2171 gfc_notify_std (GFC_STD_F2003,
2172 "CONTAINS block in derived type"
2173 " definition at %C");
2174
2175 accept_statement (ST_CONTAINS);
2176 parse_derived_contains ();
2177 goto endType;
2178
2179 default:
2180 unexpected_statement (st);
2181 break;
2182 }
2183 }
2184
2185 /* need to verify that all fields of the derived type are
2186 * interoperable with C if the type is declared to be bind(c)
2187 */
2188 sym = gfc_current_block ();
2189 for (c = sym->components; c; c = c->next)
2190 {
2191 bool coarray, lock_type, allocatable, pointer;
2192 coarray = lock_type = allocatable = pointer = false;
2193
2194 /* Look for allocatable components. */
2195 if (c->attr.allocatable
2196 || (c->ts.type == BT_CLASS && c->attr.class_ok
2197 && CLASS_DATA (c)->attr.allocatable)
2198 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2199 {
2200 allocatable = true;
2201 sym->attr.alloc_comp = 1;
2202 }
2203
2204 /* Look for pointer components. */
2205 if (c->attr.pointer
2206 || (c->ts.type == BT_CLASS && c->attr.class_ok
2207 && CLASS_DATA (c)->attr.class_pointer)
2208 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2209 {
2210 pointer = true;
2211 sym->attr.pointer_comp = 1;
2212 }
2213
2214 /* Look for procedure pointer components. */
2215 if (c->attr.proc_pointer
2216 || (c->ts.type == BT_DERIVED
2217 && c->ts.u.derived->attr.proc_pointer_comp))
2218 sym->attr.proc_pointer_comp = 1;
2219
2220 /* Looking for coarray components. */
2221 if (c->attr.codimension
2222 || (c->ts.type == BT_CLASS && c->attr.class_ok
2223 && CLASS_DATA (c)->attr.codimension))
2224 {
2225 coarray = true;
2226 sym->attr.coarray_comp = 1;
2227 }
2228
2229 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp)
2230 {
2231 coarray = true;
2232 if (!pointer && !allocatable)
2233 sym->attr.coarray_comp = 1;
2234 }
2235
2236 /* Looking for lock_type components. */
2237 if ((c->ts.type == BT_DERIVED
2238 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2239 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2240 || (c->ts.type == BT_CLASS && c->attr.class_ok
2241 && CLASS_DATA (c)->ts.u.derived->from_intmod
2242 == INTMOD_ISO_FORTRAN_ENV
2243 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
2244 == ISOFORTRAN_LOCK_TYPE)
2245 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
2246 && !allocatable && !pointer))
2247 {
2248 lock_type = 1;
2249 lock_comp = c;
2250 sym->attr.lock_comp = 1;
2251 }
2252
2253 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2254 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2255 unless there are nondirect [allocatable or pointer] components
2256 involved (cf. 1.3.33.1 and 1.3.33.3). */
2257
2258 if (pointer && !coarray && lock_type)
2259 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2260 "codimension or be a subcomponent of a coarray, "
2261 "which is not possible as the component has the "
2262 "pointer attribute", c->name, &c->loc);
2263 else if (pointer && !coarray && c->ts.type == BT_DERIVED
2264 && c->ts.u.derived->attr.lock_comp)
2265 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2266 "of type LOCK_TYPE, which must have a codimension or be a "
2267 "subcomponent of a coarray", c->name, &c->loc);
2268
2269 if (lock_type && allocatable && !coarray)
2270 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2271 "a codimension", c->name, &c->loc);
2272 else if (lock_type && allocatable && c->ts.type == BT_DERIVED
2273 && c->ts.u.derived->attr.lock_comp)
2274 gfc_error ("Allocatable component %s at %L must have a codimension as "
2275 "it has a noncoarray subcomponent of type LOCK_TYPE",
2276 c->name, &c->loc);
2277
2278 if (sym->attr.coarray_comp && !coarray && lock_type)
2279 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2280 "subcomponent of type LOCK_TYPE must have a codimension or "
2281 "be a subcomponent of a coarray. (Variables of type %s may "
2282 "not have a codimension as already a coarray "
2283 "subcomponent exists)", c->name, &c->loc, sym->name);
2284
2285 if (sym->attr.lock_comp && coarray && !lock_type)
2286 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2287 "subcomponent of type LOCK_TYPE must have a codimension or "
2288 "be a subcomponent of a coarray. (Variables of type %s may "
2289 "not have a codimension as %s at %L has a codimension or a "
2290 "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
2291 sym->name, c->name, &c->loc);
2292
2293 /* Look for private components. */
2294 if (sym->component_access == ACCESS_PRIVATE
2295 || c->attr.access == ACCESS_PRIVATE
2296 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2297 sym->attr.private_comp = 1;
2298 }
2299
2300 if (!seen_component)
2301 sym->attr.zero_comp = 1;
2302
2303 pop_state ();
2304 }
2305
2306
2307 /* Parse an ENUM. */
2308
2309 static void
2310 parse_enum (void)
2311 {
2312 gfc_statement st;
2313 int compiling_enum;
2314 gfc_state_data s;
2315 int seen_enumerator = 0;
2316
2317 push_state (&s, COMP_ENUM, gfc_new_block);
2318
2319 compiling_enum = 1;
2320
2321 while (compiling_enum)
2322 {
2323 st = next_statement ();
2324 switch (st)
2325 {
2326 case ST_NONE:
2327 unexpected_eof ();
2328 break;
2329
2330 case ST_ENUMERATOR:
2331 seen_enumerator = 1;
2332 accept_statement (st);
2333 break;
2334
2335 case ST_END_ENUM:
2336 compiling_enum = 0;
2337 if (!seen_enumerator)
2338 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2339 accept_statement (st);
2340 break;
2341
2342 default:
2343 gfc_free_enum_history ();
2344 unexpected_statement (st);
2345 break;
2346 }
2347 }
2348 pop_state ();
2349 }
2350
2351
2352 /* Parse an interface. We must be able to deal with the possibility
2353 of recursive interfaces. The parse_spec() subroutine is mutually
2354 recursive with parse_interface(). */
2355
2356 static gfc_statement parse_spec (gfc_statement);
2357
2358 static void
2359 parse_interface (void)
2360 {
2361 gfc_compile_state new_state = COMP_NONE, current_state;
2362 gfc_symbol *prog_unit, *sym;
2363 gfc_interface_info save;
2364 gfc_state_data s1, s2;
2365 gfc_statement st;
2366 locus proc_locus;
2367
2368 accept_statement (ST_INTERFACE);
2369
2370 current_interface.ns = gfc_current_ns;
2371 save = current_interface;
2372
2373 sym = (current_interface.type == INTERFACE_GENERIC
2374 || current_interface.type == INTERFACE_USER_OP)
2375 ? gfc_new_block : NULL;
2376
2377 push_state (&s1, COMP_INTERFACE, sym);
2378 current_state = COMP_NONE;
2379
2380 loop:
2381 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2382
2383 st = next_statement ();
2384 switch (st)
2385 {
2386 case ST_NONE:
2387 unexpected_eof ();
2388
2389 case ST_SUBROUTINE:
2390 case ST_FUNCTION:
2391 if (st == ST_SUBROUTINE)
2392 new_state = COMP_SUBROUTINE;
2393 else if (st == ST_FUNCTION)
2394 new_state = COMP_FUNCTION;
2395 if (gfc_new_block->attr.pointer)
2396 {
2397 gfc_new_block->attr.pointer = 0;
2398 gfc_new_block->attr.proc_pointer = 1;
2399 }
2400 if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2401 gfc_new_block->formal, NULL) == FAILURE)
2402 {
2403 reject_statement ();
2404 gfc_free_namespace (gfc_current_ns);
2405 goto loop;
2406 }
2407 break;
2408
2409 case ST_PROCEDURE:
2410 case ST_MODULE_PROC: /* The module procedure matcher makes
2411 sure the context is correct. */
2412 accept_statement (st);
2413 gfc_free_namespace (gfc_current_ns);
2414 goto loop;
2415
2416 case ST_END_INTERFACE:
2417 gfc_free_namespace (gfc_current_ns);
2418 gfc_current_ns = current_interface.ns;
2419 goto done;
2420
2421 default:
2422 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2423 gfc_ascii_statement (st));
2424 reject_statement ();
2425 gfc_free_namespace (gfc_current_ns);
2426 goto loop;
2427 }
2428
2429
2430 /* Make sure that the generic name has the right attribute. */
2431 if (current_interface.type == INTERFACE_GENERIC
2432 && current_state == COMP_NONE)
2433 {
2434 if (new_state == COMP_FUNCTION && sym)
2435 gfc_add_function (&sym->attr, sym->name, NULL);
2436 else if (new_state == COMP_SUBROUTINE && sym)
2437 gfc_add_subroutine (&sym->attr, sym->name, NULL);
2438
2439 current_state = new_state;
2440 }
2441
2442 if (current_interface.type == INTERFACE_ABSTRACT)
2443 {
2444 gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2445 if (gfc_is_intrinsic_typename (gfc_new_block->name))
2446 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2447 "cannot be the same as an intrinsic type",
2448 gfc_new_block->name);
2449 }
2450
2451 push_state (&s2, new_state, gfc_new_block);
2452 accept_statement (st);
2453 prog_unit = gfc_new_block;
2454 prog_unit->formal_ns = gfc_current_ns;
2455 proc_locus = gfc_current_locus;
2456
2457 decl:
2458 /* Read data declaration statements. */
2459 st = parse_spec (ST_NONE);
2460
2461 /* Since the interface block does not permit an IMPLICIT statement,
2462 the default type for the function or the result must be taken
2463 from the formal namespace. */
2464 if (new_state == COMP_FUNCTION)
2465 {
2466 if (prog_unit->result == prog_unit
2467 && prog_unit->ts.type == BT_UNKNOWN)
2468 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2469 else if (prog_unit->result != prog_unit
2470 && prog_unit->result->ts.type == BT_UNKNOWN)
2471 gfc_set_default_type (prog_unit->result, 1,
2472 prog_unit->formal_ns);
2473 }
2474
2475 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2476 {
2477 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2478 gfc_ascii_statement (st));
2479 reject_statement ();
2480 goto decl;
2481 }
2482
2483 /* Add EXTERNAL attribute to function or subroutine. */
2484 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2485 gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2486
2487 current_interface = save;
2488 gfc_add_interface (prog_unit);
2489 pop_state ();
2490
2491 if (current_interface.ns
2492 && current_interface.ns->proc_name
2493 && strcmp (current_interface.ns->proc_name->name,
2494 prog_unit->name) == 0)
2495 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2496 "enclosing procedure", prog_unit->name, &proc_locus);
2497
2498 goto loop;
2499
2500 done:
2501 pop_state ();
2502 }
2503
2504
2505 /* Associate function characteristics by going back to the function
2506 declaration and rematching the prefix. */
2507
2508 static match
2509 match_deferred_characteristics (gfc_typespec * ts)
2510 {
2511 locus loc;
2512 match m = MATCH_ERROR;
2513 char name[GFC_MAX_SYMBOL_LEN + 1];
2514
2515 loc = gfc_current_locus;
2516
2517 gfc_current_locus = gfc_current_block ()->declared_at;
2518
2519 gfc_clear_error ();
2520 gfc_buffer_error (1);
2521 m = gfc_match_prefix (ts);
2522 gfc_buffer_error (0);
2523
2524 if (ts->type == BT_DERIVED)
2525 {
2526 ts->kind = 0;
2527
2528 if (!ts->u.derived)
2529 m = MATCH_ERROR;
2530 }
2531
2532 /* Only permit one go at the characteristic association. */
2533 if (ts->kind == -1)
2534 ts->kind = 0;
2535
2536 /* Set the function locus correctly. If we have not found the
2537 function name, there is an error. */
2538 if (m == MATCH_YES
2539 && gfc_match ("function% %n", name) == MATCH_YES
2540 && strcmp (name, gfc_current_block ()->name) == 0)
2541 {
2542 gfc_current_block ()->declared_at = gfc_current_locus;
2543 gfc_commit_symbols ();
2544 }
2545 else
2546 {
2547 gfc_error_check ();
2548 gfc_undo_symbols ();
2549 }
2550
2551 gfc_current_locus =loc;
2552 return m;
2553 }
2554
2555
2556 /* Check specification-expressions in the function result of the currently
2557 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2558 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2559 scope are not yet parsed so this has to be delayed up to parse_spec. */
2560
2561 static void
2562 check_function_result_typed (void)
2563 {
2564 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2565
2566 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2567 gcc_assert (ts->type != BT_UNKNOWN);
2568
2569 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2570 /* TODO: Extend when KIND type parameters are implemented. */
2571 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2572 gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2573 }
2574
2575
2576 /* Parse a set of specification statements. Returns the statement
2577 that doesn't fit. */
2578
2579 static gfc_statement
2580 parse_spec (gfc_statement st)
2581 {
2582 st_state ss;
2583 bool function_result_typed = false;
2584 bool bad_characteristic = false;
2585 gfc_typespec *ts;
2586
2587 verify_st_order (&ss, ST_NONE, false);
2588 if (st == ST_NONE)
2589 st = next_statement ();
2590
2591 /* If we are not inside a function or don't have a result specified so far,
2592 do nothing special about it. */
2593 if (gfc_current_state () != COMP_FUNCTION)
2594 function_result_typed = true;
2595 else
2596 {
2597 gfc_symbol* proc = gfc_current_ns->proc_name;
2598 gcc_assert (proc);
2599
2600 if (proc->result->ts.type == BT_UNKNOWN)
2601 function_result_typed = true;
2602 }
2603
2604 loop:
2605
2606 /* If we're inside a BLOCK construct, some statements are disallowed.
2607 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2608 or VALUE are also disallowed, but they don't have a particular ST_*
2609 key so we have to check for them individually in their matcher routine. */
2610 if (gfc_current_state () == COMP_BLOCK)
2611 switch (st)
2612 {
2613 case ST_IMPLICIT:
2614 case ST_IMPLICIT_NONE:
2615 case ST_NAMELIST:
2616 case ST_COMMON:
2617 case ST_EQUIVALENCE:
2618 case ST_STATEMENT_FUNCTION:
2619 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2620 gfc_ascii_statement (st));
2621 reject_statement ();
2622 break;
2623
2624 default:
2625 break;
2626 }
2627
2628 /* If we find a statement that can not be followed by an IMPLICIT statement
2629 (and thus we can expect to see none any further), type the function result
2630 if it has not yet been typed. Be careful not to give the END statement
2631 to verify_st_order! */
2632 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2633 {
2634 bool verify_now = false;
2635
2636 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2637 verify_now = true;
2638 else
2639 {
2640 st_state dummyss;
2641 verify_st_order (&dummyss, ST_NONE, false);
2642 verify_st_order (&dummyss, st, false);
2643
2644 if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2645 verify_now = true;
2646 }
2647
2648 if (verify_now)
2649 {
2650 check_function_result_typed ();
2651 function_result_typed = true;
2652 }
2653 }
2654
2655 switch (st)
2656 {
2657 case ST_NONE:
2658 unexpected_eof ();
2659
2660 case ST_IMPLICIT_NONE:
2661 case ST_IMPLICIT:
2662 if (!function_result_typed)
2663 {
2664 check_function_result_typed ();
2665 function_result_typed = true;
2666 }
2667 goto declSt;
2668
2669 case ST_FORMAT:
2670 case ST_ENTRY:
2671 case ST_DATA: /* Not allowed in interfaces */
2672 if (gfc_current_state () == COMP_INTERFACE)
2673 break;
2674
2675 /* Fall through */
2676
2677 case ST_USE:
2678 case ST_IMPORT:
2679 case ST_PARAMETER:
2680 case ST_PUBLIC:
2681 case ST_PRIVATE:
2682 case ST_DERIVED_DECL:
2683 case_decl:
2684 declSt:
2685 if (verify_st_order (&ss, st, false) == FAILURE)
2686 {
2687 reject_statement ();
2688 st = next_statement ();
2689 goto loop;
2690 }
2691
2692 switch (st)
2693 {
2694 case ST_INTERFACE:
2695 parse_interface ();
2696 break;
2697
2698 case ST_DERIVED_DECL:
2699 parse_derived ();
2700 break;
2701
2702 case ST_PUBLIC:
2703 case ST_PRIVATE:
2704 if (gfc_current_state () != COMP_MODULE)
2705 {
2706 gfc_error ("%s statement must appear in a MODULE",
2707 gfc_ascii_statement (st));
2708 reject_statement ();
2709 break;
2710 }
2711
2712 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2713 {
2714 gfc_error ("%s statement at %C follows another accessibility "
2715 "specification", gfc_ascii_statement (st));
2716 reject_statement ();
2717 break;
2718 }
2719
2720 gfc_current_ns->default_access = (st == ST_PUBLIC)
2721 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2722
2723 break;
2724
2725 case ST_STATEMENT_FUNCTION:
2726 if (gfc_current_state () == COMP_MODULE)
2727 {
2728 unexpected_statement (st);
2729 break;
2730 }
2731
2732 default:
2733 break;
2734 }
2735
2736 accept_statement (st);
2737 st = next_statement ();
2738 goto loop;
2739
2740 case ST_ENUM:
2741 accept_statement (st);
2742 parse_enum();
2743 st = next_statement ();
2744 goto loop;
2745
2746 case ST_GET_FCN_CHARACTERISTICS:
2747 /* This statement triggers the association of a function's result
2748 characteristics. */
2749 ts = &gfc_current_block ()->result->ts;
2750 if (match_deferred_characteristics (ts) != MATCH_YES)
2751 bad_characteristic = true;
2752
2753 st = next_statement ();
2754 goto loop;
2755
2756 default:
2757 break;
2758 }
2759
2760 /* If match_deferred_characteristics failed, then there is an error. */
2761 if (bad_characteristic)
2762 {
2763 ts = &gfc_current_block ()->result->ts;
2764 if (ts->type != BT_DERIVED)
2765 gfc_error ("Bad kind expression for function '%s' at %L",
2766 gfc_current_block ()->name,
2767 &gfc_current_block ()->declared_at);
2768 else
2769 gfc_error ("The type for function '%s' at %L is not accessible",
2770 gfc_current_block ()->name,
2771 &gfc_current_block ()->declared_at);
2772
2773 gfc_current_block ()->ts.kind = 0;
2774 /* Keep the derived type; if it's bad, it will be discovered later. */
2775 if (!(ts->type == BT_DERIVED && ts->u.derived))
2776 ts->type = BT_UNKNOWN;
2777 }
2778
2779 return st;
2780 }
2781
2782
2783 /* Parse a WHERE block, (not a simple WHERE statement). */
2784
2785 static void
2786 parse_where_block (void)
2787 {
2788 int seen_empty_else;
2789 gfc_code *top, *d;
2790 gfc_state_data s;
2791 gfc_statement st;
2792
2793 accept_statement (ST_WHERE_BLOCK);
2794 top = gfc_state_stack->tail;
2795
2796 push_state (&s, COMP_WHERE, gfc_new_block);
2797
2798 d = add_statement ();
2799 d->expr1 = top->expr1;
2800 d->op = EXEC_WHERE;
2801
2802 top->expr1 = NULL;
2803 top->block = d;
2804
2805 seen_empty_else = 0;
2806
2807 do
2808 {
2809 st = next_statement ();
2810 switch (st)
2811 {
2812 case ST_NONE:
2813 unexpected_eof ();
2814
2815 case ST_WHERE_BLOCK:
2816 parse_where_block ();
2817 break;
2818
2819 case ST_ASSIGNMENT:
2820 case ST_WHERE:
2821 accept_statement (st);
2822 break;
2823
2824 case ST_ELSEWHERE:
2825 if (seen_empty_else)
2826 {
2827 gfc_error ("ELSEWHERE statement at %C follows previous "
2828 "unmasked ELSEWHERE");
2829 reject_statement ();
2830 break;
2831 }
2832
2833 if (new_st.expr1 == NULL)
2834 seen_empty_else = 1;
2835
2836 d = new_level (gfc_state_stack->head);
2837 d->op = EXEC_WHERE;
2838 d->expr1 = new_st.expr1;
2839
2840 accept_statement (st);
2841
2842 break;
2843
2844 case ST_END_WHERE:
2845 accept_statement (st);
2846 break;
2847
2848 default:
2849 gfc_error ("Unexpected %s statement in WHERE block at %C",
2850 gfc_ascii_statement (st));
2851 reject_statement ();
2852 break;
2853 }
2854 }
2855 while (st != ST_END_WHERE);
2856
2857 pop_state ();
2858 }
2859
2860
2861 /* Parse a FORALL block (not a simple FORALL statement). */
2862
2863 static void
2864 parse_forall_block (void)
2865 {
2866 gfc_code *top, *d;
2867 gfc_state_data s;
2868 gfc_statement st;
2869
2870 accept_statement (ST_FORALL_BLOCK);
2871 top = gfc_state_stack->tail;
2872
2873 push_state (&s, COMP_FORALL, gfc_new_block);
2874
2875 d = add_statement ();
2876 d->op = EXEC_FORALL;
2877 top->block = d;
2878
2879 do
2880 {
2881 st = next_statement ();
2882 switch (st)
2883 {
2884
2885 case ST_ASSIGNMENT:
2886 case ST_POINTER_ASSIGNMENT:
2887 case ST_WHERE:
2888 case ST_FORALL:
2889 accept_statement (st);
2890 break;
2891
2892 case ST_WHERE_BLOCK:
2893 parse_where_block ();
2894 break;
2895
2896 case ST_FORALL_BLOCK:
2897 parse_forall_block ();
2898 break;
2899
2900 case ST_END_FORALL:
2901 accept_statement (st);
2902 break;
2903
2904 case ST_NONE:
2905 unexpected_eof ();
2906
2907 default:
2908 gfc_error ("Unexpected %s statement in FORALL block at %C",
2909 gfc_ascii_statement (st));
2910
2911 reject_statement ();
2912 break;
2913 }
2914 }
2915 while (st != ST_END_FORALL);
2916
2917 pop_state ();
2918 }
2919
2920
2921 static gfc_statement parse_executable (gfc_statement);
2922
2923 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2924
2925 static void
2926 parse_if_block (void)
2927 {
2928 gfc_code *top, *d;
2929 gfc_statement st;
2930 locus else_locus;
2931 gfc_state_data s;
2932 int seen_else;
2933
2934 seen_else = 0;
2935 accept_statement (ST_IF_BLOCK);
2936
2937 top = gfc_state_stack->tail;
2938 push_state (&s, COMP_IF, gfc_new_block);
2939
2940 new_st.op = EXEC_IF;
2941 d = add_statement ();
2942
2943 d->expr1 = top->expr1;
2944 top->expr1 = NULL;
2945 top->block = d;
2946
2947 do
2948 {
2949 st = parse_executable (ST_NONE);
2950
2951 switch (st)
2952 {
2953 case ST_NONE:
2954 unexpected_eof ();
2955
2956 case ST_ELSEIF:
2957 if (seen_else)
2958 {
2959 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2960 "statement at %L", &else_locus);
2961
2962 reject_statement ();
2963 break;
2964 }
2965
2966 d = new_level (gfc_state_stack->head);
2967 d->op = EXEC_IF;
2968 d->expr1 = new_st.expr1;
2969
2970 accept_statement (st);
2971
2972 break;
2973
2974 case ST_ELSE:
2975 if (seen_else)
2976 {
2977 gfc_error ("Duplicate ELSE statements at %L and %C",
2978 &else_locus);
2979 reject_statement ();
2980 break;
2981 }
2982
2983 seen_else = 1;
2984 else_locus = gfc_current_locus;
2985
2986 d = new_level (gfc_state_stack->head);
2987 d->op = EXEC_IF;
2988
2989 accept_statement (st);
2990
2991 break;
2992
2993 case ST_ENDIF:
2994 break;
2995
2996 default:
2997 unexpected_statement (st);
2998 break;
2999 }
3000 }
3001 while (st != ST_ENDIF);
3002
3003 pop_state ();
3004 accept_statement (st);
3005 }
3006
3007
3008 /* Parse a SELECT block. */
3009
3010 static void
3011 parse_select_block (void)
3012 {
3013 gfc_statement st;
3014 gfc_code *cp;
3015 gfc_state_data s;
3016
3017 accept_statement (ST_SELECT_CASE);
3018
3019 cp = gfc_state_stack->tail;
3020 push_state (&s, COMP_SELECT, gfc_new_block);
3021
3022 /* Make sure that the next statement is a CASE or END SELECT. */
3023 for (;;)
3024 {
3025 st = next_statement ();
3026 if (st == ST_NONE)
3027 unexpected_eof ();
3028 if (st == ST_END_SELECT)
3029 {
3030 /* Empty SELECT CASE is OK. */
3031 accept_statement (st);
3032 pop_state ();
3033 return;
3034 }
3035 if (st == ST_CASE)
3036 break;
3037
3038 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3039 "CASE at %C");
3040
3041 reject_statement ();
3042 }
3043
3044 /* At this point, we're got a nonempty select block. */
3045 cp = new_level (cp);
3046 *cp = new_st;
3047
3048 accept_statement (st);
3049
3050 do
3051 {
3052 st = parse_executable (ST_NONE);
3053 switch (st)
3054 {
3055 case ST_NONE:
3056 unexpected_eof ();
3057
3058 case ST_CASE:
3059 cp = new_level (gfc_state_stack->head);
3060 *cp = new_st;
3061 gfc_clear_new_st ();
3062
3063 accept_statement (st);
3064 /* Fall through */
3065
3066 case ST_END_SELECT:
3067 break;
3068
3069 /* Can't have an executable statement because of
3070 parse_executable(). */
3071 default:
3072 unexpected_statement (st);
3073 break;
3074 }
3075 }
3076 while (st != ST_END_SELECT);
3077
3078 pop_state ();
3079 accept_statement (st);
3080 }
3081
3082
3083 /* Pop the current selector from the SELECT TYPE stack. */
3084
3085 static void
3086 select_type_pop (void)
3087 {
3088 gfc_select_type_stack *old = select_type_stack;
3089 select_type_stack = old->prev;
3090 free (old);
3091 }
3092
3093
3094 /* Parse a SELECT TYPE construct (F03:R821). */
3095
3096 static void
3097 parse_select_type_block (void)
3098 {
3099 gfc_statement st;
3100 gfc_code *cp;
3101 gfc_state_data s;
3102
3103 accept_statement (ST_SELECT_TYPE);
3104
3105 cp = gfc_state_stack->tail;
3106 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
3107
3108 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3109 or END SELECT. */
3110 for (;;)
3111 {
3112 st = next_statement ();
3113 if (st == ST_NONE)
3114 unexpected_eof ();
3115 if (st == ST_END_SELECT)
3116 /* Empty SELECT CASE is OK. */
3117 goto done;
3118 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
3119 break;
3120
3121 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3122 "following SELECT TYPE at %C");
3123
3124 reject_statement ();
3125 }
3126
3127 /* At this point, we're got a nonempty select block. */
3128 cp = new_level (cp);
3129 *cp = new_st;
3130
3131 accept_statement (st);
3132
3133 do
3134 {
3135 st = parse_executable (ST_NONE);
3136 switch (st)
3137 {
3138 case ST_NONE:
3139 unexpected_eof ();
3140
3141 case ST_TYPE_IS:
3142 case ST_CLASS_IS:
3143 cp = new_level (gfc_state_stack->head);
3144 *cp = new_st;
3145 gfc_clear_new_st ();
3146
3147 accept_statement (st);
3148 /* Fall through */
3149
3150 case ST_END_SELECT:
3151 break;
3152
3153 /* Can't have an executable statement because of
3154 parse_executable(). */
3155 default:
3156 unexpected_statement (st);
3157 break;
3158 }
3159 }
3160 while (st != ST_END_SELECT);
3161
3162 done:
3163 pop_state ();
3164 accept_statement (st);
3165 gfc_current_ns = gfc_current_ns->parent;
3166 select_type_pop ();
3167 }
3168
3169
3170 /* Given a symbol, make sure it is not an iteration variable for a DO
3171 statement. This subroutine is called when the symbol is seen in a
3172 context that causes it to become redefined. If the symbol is an
3173 iterator, we generate an error message and return nonzero. */
3174
3175 int
3176 gfc_check_do_variable (gfc_symtree *st)
3177 {
3178 gfc_state_data *s;
3179
3180 for (s=gfc_state_stack; s; s = s->previous)
3181 if (s->do_variable == st)
3182 {
3183 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3184 "loop beginning at %L", st->name, &s->head->loc);
3185 return 1;
3186 }
3187
3188 return 0;
3189 }
3190
3191
3192 /* Checks to see if the current statement label closes an enddo.
3193 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3194 an error) if it incorrectly closes an ENDDO. */
3195
3196 static int
3197 check_do_closure (void)
3198 {
3199 gfc_state_data *p;
3200
3201 if (gfc_statement_label == NULL)
3202 return 0;
3203
3204 for (p = gfc_state_stack; p; p = p->previous)
3205 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3206 break;
3207
3208 if (p == NULL)
3209 return 0; /* No loops to close */
3210
3211 if (p->ext.end_do_label == gfc_statement_label)
3212 {
3213 if (p == gfc_state_stack)
3214 return 1;
3215
3216 gfc_error ("End of nonblock DO statement at %C is within another block");
3217 return 2;
3218 }
3219
3220 /* At this point, the label doesn't terminate the innermost loop.
3221 Make sure it doesn't terminate another one. */
3222 for (; p; p = p->previous)
3223 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3224 && p->ext.end_do_label == gfc_statement_label)
3225 {
3226 gfc_error ("End of nonblock DO statement at %C is interwoven "
3227 "with another DO loop");
3228 return 2;
3229 }
3230
3231 return 0;
3232 }
3233
3234
3235 /* Parse a series of contained program units. */
3236
3237 static void parse_progunit (gfc_statement);
3238
3239
3240 /* Parse a CRITICAL block. */
3241
3242 static void
3243 parse_critical_block (void)
3244 {
3245 gfc_code *top, *d;
3246 gfc_state_data s;
3247 gfc_statement st;
3248
3249 s.ext.end_do_label = new_st.label1;
3250
3251 accept_statement (ST_CRITICAL);
3252 top = gfc_state_stack->tail;
3253
3254 push_state (&s, COMP_CRITICAL, gfc_new_block);
3255
3256 d = add_statement ();
3257 d->op = EXEC_CRITICAL;
3258 top->block = d;
3259
3260 do
3261 {
3262 st = parse_executable (ST_NONE);
3263
3264 switch (st)
3265 {
3266 case ST_NONE:
3267 unexpected_eof ();
3268 break;
3269
3270 case ST_END_CRITICAL:
3271 if (s.ext.end_do_label != NULL
3272 && s.ext.end_do_label != gfc_statement_label)
3273 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3274 "match CRITICAL label");
3275
3276 if (gfc_statement_label != NULL)
3277 {
3278 new_st.op = EXEC_NOP;
3279 add_statement ();
3280 }
3281 break;
3282
3283 default:
3284 unexpected_statement (st);
3285 break;
3286 }
3287 }
3288 while (st != ST_END_CRITICAL);
3289
3290 pop_state ();
3291 accept_statement (st);
3292 }
3293
3294
3295 /* Set up the local namespace for a BLOCK construct. */
3296
3297 gfc_namespace*
3298 gfc_build_block_ns (gfc_namespace *parent_ns)
3299 {
3300 gfc_namespace* my_ns;
3301 static int numblock = 1;
3302
3303 my_ns = gfc_get_namespace (parent_ns, 1);
3304 my_ns->construct_entities = 1;
3305
3306 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3307 code generation (so it must not be NULL).
3308 We set its recursive argument if our container procedure is recursive, so
3309 that local variables are accordingly placed on the stack when it
3310 will be necessary. */
3311 if (gfc_new_block)
3312 my_ns->proc_name = gfc_new_block;
3313 else
3314 {
3315 gfc_try t;
3316 char buffer[20]; /* Enough to hold "block@2147483648\n". */
3317
3318 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
3319 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
3320 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3321 my_ns->proc_name->name, NULL);
3322 gcc_assert (t == SUCCESS);
3323 gfc_commit_symbol (my_ns->proc_name);
3324 }
3325
3326 if (parent_ns->proc_name)
3327 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3328
3329 return my_ns;
3330 }
3331
3332
3333 /* Parse a BLOCK construct. */
3334
3335 static void
3336 parse_block_construct (void)
3337 {
3338 gfc_namespace* my_ns;
3339 gfc_state_data s;
3340
3341 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
3342
3343 my_ns = gfc_build_block_ns (gfc_current_ns);
3344
3345 new_st.op = EXEC_BLOCK;
3346 new_st.ext.block.ns = my_ns;
3347 new_st.ext.block.assoc = NULL;
3348 accept_statement (ST_BLOCK);
3349
3350 push_state (&s, COMP_BLOCK, my_ns->proc_name);
3351 gfc_current_ns = my_ns;
3352
3353 parse_progunit (ST_NONE);
3354
3355 gfc_current_ns = gfc_current_ns->parent;
3356 pop_state ();
3357 }
3358
3359
3360 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3361 behind the scenes with compiler-generated variables. */
3362
3363 static void
3364 parse_associate (void)
3365 {
3366 gfc_namespace* my_ns;
3367 gfc_state_data s;
3368 gfc_statement st;
3369 gfc_association_list* a;
3370
3371 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
3372
3373 my_ns = gfc_build_block_ns (gfc_current_ns);
3374
3375 new_st.op = EXEC_BLOCK;
3376 new_st.ext.block.ns = my_ns;
3377 gcc_assert (new_st.ext.block.assoc);
3378
3379 /* Add all associate-names as BLOCK variables. Creating them is enough
3380 for now, they'll get their values during trans-* phase. */
3381 gfc_current_ns = my_ns;
3382 for (a = new_st.ext.block.assoc; a; a = a->next)
3383 {
3384 gfc_symbol* sym;
3385
3386 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3387 gcc_unreachable ();
3388
3389 sym = a->st->n.sym;
3390 sym->attr.flavor = FL_VARIABLE;
3391 sym->assoc = a;
3392 sym->declared_at = a->where;
3393 gfc_set_sym_referenced (sym);
3394
3395 /* Initialize the typespec. It is not available in all cases,
3396 however, as it may only be set on the target during resolution.
3397 Still, sometimes it helps to have it right now -- especially
3398 for parsing component references on the associate-name
3399 in case of association to a derived-type. */
3400 sym->ts = a->target->ts;
3401 }
3402
3403 accept_statement (ST_ASSOCIATE);
3404 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3405
3406 loop:
3407 st = parse_executable (ST_NONE);
3408 switch (st)
3409 {
3410 case ST_NONE:
3411 unexpected_eof ();
3412
3413 case_end:
3414 accept_statement (st);
3415 my_ns->code = gfc_state_stack->head;
3416 break;
3417
3418 default:
3419 unexpected_statement (st);
3420 goto loop;
3421 }
3422
3423 gfc_current_ns = gfc_current_ns->parent;
3424 pop_state ();
3425 }
3426
3427
3428 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3429 handled inside of parse_executable(), because they aren't really
3430 loop statements. */
3431
3432 static void
3433 parse_do_block (void)
3434 {
3435 gfc_statement st;
3436 gfc_code *top;
3437 gfc_state_data s;
3438 gfc_symtree *stree;
3439 gfc_exec_op do_op;
3440
3441 do_op = new_st.op;
3442 s.ext.end_do_label = new_st.label1;
3443
3444 if (new_st.ext.iterator != NULL)
3445 stree = new_st.ext.iterator->var->symtree;
3446 else
3447 stree = NULL;
3448
3449 accept_statement (ST_DO);
3450
3451 top = gfc_state_stack->tail;
3452 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
3453 gfc_new_block);
3454
3455 s.do_variable = stree;
3456
3457 top->block = new_level (top);
3458 top->block->op = EXEC_DO;
3459
3460 loop:
3461 st = parse_executable (ST_NONE);
3462
3463 switch (st)
3464 {
3465 case ST_NONE:
3466 unexpected_eof ();
3467
3468 case ST_ENDDO:
3469 if (s.ext.end_do_label != NULL
3470 && s.ext.end_do_label != gfc_statement_label)
3471 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3472 "DO label");
3473
3474 if (gfc_statement_label != NULL)
3475 {
3476 new_st.op = EXEC_NOP;
3477 add_statement ();
3478 }
3479 break;
3480
3481 case ST_IMPLIED_ENDDO:
3482 /* If the do-stmt of this DO construct has a do-construct-name,
3483 the corresponding end-do must be an end-do-stmt (with a matching
3484 name, but in that case we must have seen ST_ENDDO first).
3485 We only complain about this in pedantic mode. */
3486 if (gfc_current_block () != NULL)
3487 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3488 &gfc_current_block()->declared_at);
3489
3490 break;
3491
3492 default:
3493 unexpected_statement (st);
3494 goto loop;
3495 }
3496
3497 pop_state ();
3498 accept_statement (st);
3499 }
3500
3501
3502 /* Parse the statements of OpenMP do/parallel do. */
3503
3504 static gfc_statement
3505 parse_omp_do (gfc_statement omp_st)
3506 {
3507 gfc_statement st;
3508 gfc_code *cp, *np;
3509 gfc_state_data s;
3510
3511 accept_statement (omp_st);
3512
3513 cp = gfc_state_stack->tail;
3514 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3515 np = new_level (cp);
3516 np->op = cp->op;
3517 np->block = NULL;
3518
3519 for (;;)
3520 {
3521 st = next_statement ();
3522 if (st == ST_NONE)
3523 unexpected_eof ();
3524 else if (st == ST_DO)
3525 break;
3526 else
3527 unexpected_statement (st);
3528 }
3529
3530 parse_do_block ();
3531 if (gfc_statement_label != NULL
3532 && gfc_state_stack->previous != NULL
3533 && gfc_state_stack->previous->state == COMP_DO
3534 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3535 {
3536 /* In
3537 DO 100 I=1,10
3538 !$OMP DO
3539 DO J=1,10
3540 ...
3541 100 CONTINUE
3542 there should be no !$OMP END DO. */
3543 pop_state ();
3544 return ST_IMPLIED_ENDDO;
3545 }
3546
3547 check_do_closure ();
3548 pop_state ();
3549
3550 st = next_statement ();
3551 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3552 {
3553 if (new_st.op == EXEC_OMP_END_NOWAIT)
3554 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3555 else
3556 gcc_assert (new_st.op == EXEC_NOP);
3557 gfc_clear_new_st ();
3558 gfc_commit_symbols ();
3559 gfc_warning_check ();
3560 st = next_statement ();
3561 }
3562 return st;
3563 }
3564
3565
3566 /* Parse the statements of OpenMP atomic directive. */
3567
3568 static gfc_statement
3569 parse_omp_atomic (void)
3570 {
3571 gfc_statement st;
3572 gfc_code *cp, *np;
3573 gfc_state_data s;
3574 int count;
3575
3576 accept_statement (ST_OMP_ATOMIC);
3577
3578 cp = gfc_state_stack->tail;
3579 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3580 np = new_level (cp);
3581 np->op = cp->op;
3582 np->block = NULL;
3583 count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
3584
3585 while (count)
3586 {
3587 st = next_statement ();
3588 if (st == ST_NONE)
3589 unexpected_eof ();
3590 else if (st == ST_ASSIGNMENT)
3591 {
3592 accept_statement (st);
3593 count--;
3594 }
3595 else
3596 unexpected_statement (st);
3597 }
3598
3599 pop_state ();
3600
3601 st = next_statement ();
3602 if (st == ST_OMP_END_ATOMIC)
3603 {
3604 gfc_clear_new_st ();
3605 gfc_commit_symbols ();
3606 gfc_warning_check ();
3607 st = next_statement ();
3608 }
3609 else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
3610 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3611 return st;
3612 }
3613
3614
3615 /* Parse the statements of an OpenMP structured block. */
3616
3617 static void
3618 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3619 {
3620 gfc_statement st, omp_end_st;
3621 gfc_code *cp, *np;
3622 gfc_state_data s;
3623
3624 accept_statement (omp_st);
3625
3626 cp = gfc_state_stack->tail;
3627 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3628 np = new_level (cp);
3629 np->op = cp->op;
3630 np->block = NULL;
3631
3632 switch (omp_st)
3633 {
3634 case ST_OMP_PARALLEL:
3635 omp_end_st = ST_OMP_END_PARALLEL;
3636 break;
3637 case ST_OMP_PARALLEL_SECTIONS:
3638 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3639 break;
3640 case ST_OMP_SECTIONS:
3641 omp_end_st = ST_OMP_END_SECTIONS;
3642 break;
3643 case ST_OMP_ORDERED:
3644 omp_end_st = ST_OMP_END_ORDERED;
3645 break;
3646 case ST_OMP_CRITICAL:
3647 omp_end_st = ST_OMP_END_CRITICAL;
3648 break;
3649 case ST_OMP_MASTER:
3650 omp_end_st = ST_OMP_END_MASTER;
3651 break;
3652 case ST_OMP_SINGLE:
3653 omp_end_st = ST_OMP_END_SINGLE;
3654 break;
3655 case ST_OMP_TASK:
3656 omp_end_st = ST_OMP_END_TASK;
3657 break;
3658 case ST_OMP_WORKSHARE:
3659 omp_end_st = ST_OMP_END_WORKSHARE;
3660 break;
3661 case ST_OMP_PARALLEL_WORKSHARE:
3662 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3663 break;
3664 default:
3665 gcc_unreachable ();
3666 }
3667
3668 do
3669 {
3670 if (workshare_stmts_only)
3671 {
3672 /* Inside of !$omp workshare, only
3673 scalar assignments
3674 array assignments
3675 where statements and constructs
3676 forall statements and constructs
3677 !$omp atomic
3678 !$omp critical
3679 !$omp parallel
3680 are allowed. For !$omp critical these
3681 restrictions apply recursively. */
3682 bool cycle = true;
3683
3684 st = next_statement ();
3685 for (;;)
3686 {
3687 switch (st)
3688 {
3689 case ST_NONE:
3690 unexpected_eof ();
3691
3692 case ST_ASSIGNMENT:
3693 case ST_WHERE:
3694 case ST_FORALL:
3695 accept_statement (st);
3696 break;
3697
3698 case ST_WHERE_BLOCK:
3699 parse_where_block ();
3700 break;
3701
3702 case ST_FORALL_BLOCK:
3703 parse_forall_block ();
3704 break;
3705
3706 case ST_OMP_PARALLEL:
3707 case ST_OMP_PARALLEL_SECTIONS:
3708 parse_omp_structured_block (st, false);
3709 break;
3710
3711 case ST_OMP_PARALLEL_WORKSHARE:
3712 case ST_OMP_CRITICAL:
3713 parse_omp_structured_block (st, true);
3714 break;
3715
3716 case ST_OMP_PARALLEL_DO:
3717 st = parse_omp_do (st);
3718 continue;
3719
3720 case ST_OMP_ATOMIC:
3721 st = parse_omp_atomic ();
3722 continue;
3723
3724 default:
3725 cycle = false;
3726 break;
3727 }
3728
3729 if (!cycle)
3730 break;
3731
3732 st = next_statement ();
3733 }
3734 }
3735 else
3736 st = parse_executable (ST_NONE);
3737 if (st == ST_NONE)
3738 unexpected_eof ();
3739 else if (st == ST_OMP_SECTION
3740 && (omp_st == ST_OMP_SECTIONS
3741 || omp_st == ST_OMP_PARALLEL_SECTIONS))
3742 {
3743 np = new_level (np);
3744 np->op = cp->op;
3745 np->block = NULL;
3746 }
3747 else if (st != omp_end_st)
3748 unexpected_statement (st);
3749 }
3750 while (st != omp_end_st);
3751
3752 switch (new_st.op)
3753 {
3754 case EXEC_OMP_END_NOWAIT:
3755 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3756 break;
3757 case EXEC_OMP_CRITICAL:
3758 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3759 || (new_st.ext.omp_name != NULL
3760 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3761 gfc_error ("Name after !$omp critical and !$omp end critical does "
3762 "not match at %C");
3763 free (CONST_CAST (char *, new_st.ext.omp_name));
3764 break;
3765 case EXEC_OMP_END_SINGLE:
3766 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3767 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3768 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3769 gfc_free_omp_clauses (new_st.ext.omp_clauses);
3770 break;
3771 case EXEC_NOP:
3772 break;
3773 default:
3774 gcc_unreachable ();
3775 }
3776
3777 gfc_clear_new_st ();
3778 gfc_commit_symbols ();
3779 gfc_warning_check ();
3780 pop_state ();
3781 }
3782
3783
3784 /* Accept a series of executable statements. We return the first
3785 statement that doesn't fit to the caller. Any block statements are
3786 passed on to the correct handler, which usually passes the buck
3787 right back here. */
3788
3789 static gfc_statement
3790 parse_executable (gfc_statement st)
3791 {
3792 int close_flag;
3793
3794 if (st == ST_NONE)
3795 st = next_statement ();
3796
3797 for (;;)
3798 {
3799 close_flag = check_do_closure ();
3800 if (close_flag)
3801 switch (st)
3802 {
3803 case ST_GOTO:
3804 case ST_END_PROGRAM:
3805 case ST_RETURN:
3806 case ST_EXIT:
3807 case ST_END_FUNCTION:
3808 case ST_CYCLE:
3809 case ST_PAUSE:
3810 case ST_STOP:
3811 case ST_ERROR_STOP:
3812 case ST_END_SUBROUTINE:
3813
3814 case ST_DO:
3815 case ST_FORALL:
3816 case ST_WHERE:
3817 case ST_SELECT_CASE:
3818 gfc_error ("%s statement at %C cannot terminate a non-block "
3819 "DO loop", gfc_ascii_statement (st));
3820 break;
3821
3822 default:
3823 break;
3824 }
3825
3826 switch (st)
3827 {
3828 case ST_NONE:
3829 unexpected_eof ();
3830
3831 case ST_DATA:
3832 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
3833 "first executable statement");
3834 /* Fall through. */
3835
3836 case ST_FORMAT:
3837 case ST_ENTRY:
3838 case_executable:
3839 accept_statement (st);
3840 if (close_flag == 1)
3841 return ST_IMPLIED_ENDDO;
3842 break;
3843
3844 case ST_BLOCK:
3845 parse_block_construct ();
3846 break;
3847
3848 case ST_ASSOCIATE:
3849 parse_associate ();
3850 break;
3851
3852 case ST_IF_BLOCK:
3853 parse_if_block ();
3854 break;
3855
3856 case ST_SELECT_CASE:
3857 parse_select_block ();
3858 break;
3859
3860 case ST_SELECT_TYPE:
3861 parse_select_type_block();
3862 break;
3863
3864 case ST_DO:
3865 parse_do_block ();
3866 if (check_do_closure () == 1)
3867 return ST_IMPLIED_ENDDO;
3868 break;
3869
3870 case ST_CRITICAL:
3871 parse_critical_block ();
3872 break;
3873
3874 case ST_WHERE_BLOCK:
3875 parse_where_block ();
3876 break;
3877
3878 case ST_FORALL_BLOCK:
3879 parse_forall_block ();
3880 break;
3881
3882 case ST_OMP_PARALLEL:
3883 case ST_OMP_PARALLEL_SECTIONS:
3884 case ST_OMP_SECTIONS:
3885 case ST_OMP_ORDERED:
3886 case ST_OMP_CRITICAL:
3887 case ST_OMP_MASTER:
3888 case ST_OMP_SINGLE:
3889 case ST_OMP_TASK:
3890 parse_omp_structured_block (st, false);
3891 break;
3892
3893 case ST_OMP_WORKSHARE:
3894 case ST_OMP_PARALLEL_WORKSHARE:
3895 parse_omp_structured_block (st, true);
3896 break;
3897
3898 case ST_OMP_DO:
3899 case ST_OMP_PARALLEL_DO:
3900 st = parse_omp_do (st);
3901 if (st == ST_IMPLIED_ENDDO)
3902 return st;
3903 continue;
3904
3905 case ST_OMP_ATOMIC:
3906 st = parse_omp_atomic ();
3907 continue;
3908
3909 default:
3910 return st;
3911 }
3912
3913 st = next_statement ();
3914 }
3915 }
3916
3917
3918 /* Fix the symbols for sibling functions. These are incorrectly added to
3919 the child namespace as the parser didn't know about this procedure. */
3920
3921 static void
3922 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3923 {
3924 gfc_namespace *ns;
3925 gfc_symtree *st;
3926 gfc_symbol *old_sym;
3927
3928 sym->attr.referenced = 1;
3929 for (ns = siblings; ns; ns = ns->sibling)
3930 {
3931 st = gfc_find_symtree (ns->sym_root, sym->name);
3932
3933 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3934 goto fixup_contained;
3935
3936 if ((st->n.sym->attr.flavor == FL_DERIVED
3937 && sym->attr.generic && sym->attr.function)
3938 ||(sym->attr.flavor == FL_DERIVED
3939 && st->n.sym->attr.generic && st->n.sym->attr.function))
3940 goto fixup_contained;
3941
3942 old_sym = st->n.sym;
3943 if (old_sym->ns == ns
3944 && !old_sym->attr.contained
3945
3946 /* By 14.6.1.3, host association should be excluded
3947 for the following. */
3948 && !(old_sym->attr.external
3949 || (old_sym->ts.type != BT_UNKNOWN
3950 && !old_sym->attr.implicit_type)
3951 || old_sym->attr.flavor == FL_PARAMETER
3952 || old_sym->attr.use_assoc
3953 || old_sym->attr.in_common
3954 || old_sym->attr.in_equivalence
3955 || old_sym->attr.data
3956 || old_sym->attr.dummy
3957 || old_sym->attr.result
3958 || old_sym->attr.dimension
3959 || old_sym->attr.allocatable
3960 || old_sym->attr.intrinsic
3961 || old_sym->attr.generic
3962 || old_sym->attr.flavor == FL_NAMELIST
3963 || old_sym->attr.flavor == FL_LABEL
3964 || old_sym->attr.proc == PROC_ST_FUNCTION))
3965 {
3966 /* Replace it with the symbol from the parent namespace. */
3967 st->n.sym = sym;
3968 sym->refs++;
3969
3970 gfc_release_symbol (old_sym);
3971 }
3972
3973 fixup_contained:
3974 /* Do the same for any contained procedures. */
3975 gfc_fixup_sibling_symbols (sym, ns->contained);
3976 }
3977 }
3978
3979 static void
3980 parse_contained (int module)
3981 {
3982 gfc_namespace *ns, *parent_ns, *tmp;
3983 gfc_state_data s1, s2;
3984 gfc_statement st;
3985 gfc_symbol *sym;
3986 gfc_entry_list *el;
3987 int contains_statements = 0;
3988 int seen_error = 0;
3989
3990 push_state (&s1, COMP_CONTAINS, NULL);
3991 parent_ns = gfc_current_ns;
3992
3993 do
3994 {
3995 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3996
3997 gfc_current_ns->sibling = parent_ns->contained;
3998 parent_ns->contained = gfc_current_ns;
3999
4000 next:
4001 /* Process the next available statement. We come here if we got an error
4002 and rejected the last statement. */
4003 st = next_statement ();
4004
4005 switch (st)
4006 {
4007 case ST_NONE:
4008 unexpected_eof ();
4009
4010 case ST_FUNCTION:
4011 case ST_SUBROUTINE:
4012 contains_statements = 1;
4013 accept_statement (st);
4014
4015 push_state (&s2,
4016 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
4017 gfc_new_block);
4018
4019 /* For internal procedures, create/update the symbol in the
4020 parent namespace. */
4021
4022 if (!module)
4023 {
4024 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
4025 gfc_error ("Contained procedure '%s' at %C is already "
4026 "ambiguous", gfc_new_block->name);
4027 else
4028 {
4029 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
4030 &gfc_new_block->declared_at) ==
4031 SUCCESS)
4032 {
4033 if (st == ST_FUNCTION)
4034 gfc_add_function (&sym->attr, sym->name,
4035 &gfc_new_block->declared_at);
4036 else
4037 gfc_add_subroutine (&sym->attr, sym->name,
4038 &gfc_new_block->declared_at);
4039 }
4040 }
4041
4042 gfc_commit_symbols ();
4043 }
4044 else
4045 sym = gfc_new_block;
4046
4047 /* Mark this as a contained function, so it isn't replaced
4048 by other module functions. */
4049 sym->attr.contained = 1;
4050 sym->attr.referenced = 1;
4051
4052 /* Set implicit_pure so that it can be reset if any of the
4053 tests for purity fail. This is used for some optimisation
4054 during translation. */
4055 if (!sym->attr.pure)
4056 sym->attr.implicit_pure = 1;
4057
4058 parse_progunit (ST_NONE);
4059
4060 /* Fix up any sibling functions that refer to this one. */
4061 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
4062 /* Or refer to any of its alternate entry points. */
4063 for (el = gfc_current_ns->entries; el; el = el->next)
4064 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
4065
4066 gfc_current_ns->code = s2.head;
4067 gfc_current_ns = parent_ns;
4068
4069 pop_state ();
4070 break;
4071
4072 /* These statements are associated with the end of the host unit. */
4073 case ST_END_FUNCTION:
4074 case ST_END_MODULE:
4075 case ST_END_PROGRAM:
4076 case ST_END_SUBROUTINE:
4077 accept_statement (st);
4078 break;
4079
4080 default:
4081 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4082 gfc_ascii_statement (st));
4083 reject_statement ();
4084 seen_error = 1;
4085 goto next;
4086 break;
4087 }
4088 }
4089 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
4090 && st != ST_END_MODULE && st != ST_END_PROGRAM);
4091
4092 /* The first namespace in the list is guaranteed to not have
4093 anything (worthwhile) in it. */
4094 tmp = gfc_current_ns;
4095 gfc_current_ns = parent_ns;
4096 if (seen_error && tmp->refs > 1)
4097 gfc_free_namespace (tmp);
4098
4099 ns = gfc_current_ns->contained;
4100 gfc_current_ns->contained = ns->sibling;
4101 gfc_free_namespace (ns);
4102
4103 pop_state ();
4104 if (!contains_statements)
4105 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
4106 "FUNCTION or SUBROUTINE statement at %C");
4107 }
4108
4109
4110 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4111
4112 static void
4113 parse_progunit (gfc_statement st)
4114 {
4115 gfc_state_data *p;
4116 int n;
4117
4118 st = parse_spec (st);
4119 switch (st)
4120 {
4121 case ST_NONE:
4122 unexpected_eof ();
4123
4124 case ST_CONTAINS:
4125 /* This is not allowed within BLOCK! */
4126 if (gfc_current_state () != COMP_BLOCK)
4127 goto contains;
4128 break;
4129
4130 case_end:
4131 accept_statement (st);
4132 goto done;
4133
4134 default:
4135 break;
4136 }
4137
4138 if (gfc_current_state () == COMP_FUNCTION)
4139 gfc_check_function_type (gfc_current_ns);
4140
4141 loop:
4142 for (;;)
4143 {
4144 st = parse_executable (st);
4145
4146 switch (st)
4147 {
4148 case ST_NONE:
4149 unexpected_eof ();
4150
4151 case ST_CONTAINS:
4152 /* This is not allowed within BLOCK! */
4153 if (gfc_current_state () != COMP_BLOCK)
4154 goto contains;
4155 break;
4156
4157 case_end:
4158 accept_statement (st);
4159 goto done;
4160
4161 default:
4162 break;
4163 }
4164
4165 unexpected_statement (st);
4166 reject_statement ();
4167 st = next_statement ();
4168 }
4169
4170 contains:
4171 n = 0;
4172
4173 for (p = gfc_state_stack; p; p = p->previous)
4174 if (p->state == COMP_CONTAINS)
4175 n++;
4176
4177 if (gfc_find_state (COMP_MODULE) == SUCCESS)
4178 n--;
4179
4180 if (n > 0)
4181 {
4182 gfc_error ("CONTAINS statement at %C is already in a contained "
4183 "program unit");
4184 reject_statement ();
4185 st = next_statement ();
4186 goto loop;
4187 }
4188
4189 parse_contained (0);
4190
4191 done:
4192 gfc_current_ns->code = gfc_state_stack->head;
4193 }
4194
4195
4196 /* Come here to complain about a global symbol already in use as
4197 something else. */
4198
4199 void
4200 gfc_global_used (gfc_gsymbol *sym, locus *where)
4201 {
4202 const char *name;
4203
4204 if (where == NULL)
4205 where = &gfc_current_locus;
4206
4207 switch(sym->type)
4208 {
4209 case GSYM_PROGRAM:
4210 name = "PROGRAM";
4211 break;
4212 case GSYM_FUNCTION:
4213 name = "FUNCTION";
4214 break;
4215 case GSYM_SUBROUTINE:
4216 name = "SUBROUTINE";
4217 break;
4218 case GSYM_COMMON:
4219 name = "COMMON";
4220 break;
4221 case GSYM_BLOCK_DATA:
4222 name = "BLOCK DATA";
4223 break;
4224 case GSYM_MODULE:
4225 name = "MODULE";
4226 break;
4227 default:
4228 gfc_internal_error ("gfc_global_used(): Bad type");
4229 name = NULL;
4230 }
4231
4232 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
4233 sym->name, where, name, &sym->where);
4234 }
4235
4236
4237 /* Parse a block data program unit. */
4238
4239 static void
4240 parse_block_data (void)
4241 {
4242 gfc_statement st;
4243 static locus blank_locus;
4244 static int blank_block=0;
4245 gfc_gsymbol *s;
4246
4247 gfc_current_ns->proc_name = gfc_new_block;
4248 gfc_current_ns->is_block_data = 1;
4249
4250 if (gfc_new_block == NULL)
4251 {
4252 if (blank_block)
4253 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4254 "prior BLOCK DATA at %L", &blank_locus);
4255 else
4256 {
4257 blank_block = 1;
4258 blank_locus = gfc_current_locus;
4259 }
4260 }
4261 else
4262 {
4263 s = gfc_get_gsymbol (gfc_new_block->name);
4264 if (s->defined
4265 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4266 gfc_global_used(s, NULL);
4267 else
4268 {
4269 s->type = GSYM_BLOCK_DATA;
4270 s->where = gfc_current_locus;
4271 s->defined = 1;
4272 }
4273 }
4274
4275 st = parse_spec (ST_NONE);
4276
4277 while (st != ST_END_BLOCK_DATA)
4278 {
4279 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4280 gfc_ascii_statement (st));
4281 reject_statement ();
4282 st = next_statement ();
4283 }
4284 }
4285
4286
4287 /* Parse a module subprogram. */
4288
4289 static void
4290 parse_module (void)
4291 {
4292 gfc_statement st;
4293 gfc_gsymbol *s;
4294
4295 s = gfc_get_gsymbol (gfc_new_block->name);
4296 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4297 gfc_global_used(s, NULL);
4298 else
4299 {
4300 s->type = GSYM_MODULE;
4301 s->where = gfc_current_locus;
4302 s->defined = 1;
4303 }
4304
4305 st = parse_spec (ST_NONE);
4306
4307 loop:
4308 switch (st)
4309 {
4310 case ST_NONE:
4311 unexpected_eof ();
4312
4313 case ST_CONTAINS:
4314 parse_contained (1);
4315 break;
4316
4317 case ST_END_MODULE:
4318 accept_statement (st);
4319 break;
4320
4321 default:
4322 gfc_error ("Unexpected %s statement in MODULE at %C",
4323 gfc_ascii_statement (st));
4324
4325 reject_statement ();
4326 st = next_statement ();
4327 goto loop;
4328 }
4329
4330 s->ns = gfc_current_ns;
4331 }
4332
4333
4334 /* Add a procedure name to the global symbol table. */
4335
4336 static void
4337 add_global_procedure (int sub)
4338 {
4339 gfc_gsymbol *s;
4340
4341 s = gfc_get_gsymbol(gfc_new_block->name);
4342
4343 if (s->defined
4344 || (s->type != GSYM_UNKNOWN
4345 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4346 gfc_global_used(s, NULL);
4347 else
4348 {
4349 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4350 s->where = gfc_current_locus;
4351 s->defined = 1;
4352 s->ns = gfc_current_ns;
4353 }
4354 }
4355
4356
4357 /* Add a program to the global symbol table. */
4358
4359 static void
4360 add_global_program (void)
4361 {
4362 gfc_gsymbol *s;
4363
4364 if (gfc_new_block == NULL)
4365 return;
4366 s = gfc_get_gsymbol (gfc_new_block->name);
4367
4368 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4369 gfc_global_used(s, NULL);
4370 else
4371 {
4372 s->type = GSYM_PROGRAM;
4373 s->where = gfc_current_locus;
4374 s->defined = 1;
4375 s->ns = gfc_current_ns;
4376 }
4377 }
4378
4379
4380 /* Resolve all the program units when whole file scope option
4381 is active. */
4382 static void
4383 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4384 {
4385 gfc_free_dt_list ();
4386 gfc_current_ns = gfc_global_ns_list;
4387 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4388 {
4389 if (gfc_current_ns->proc_name
4390 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4391 continue; /* Already resolved. */
4392
4393 if (gfc_current_ns->proc_name)
4394 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4395 gfc_resolve (gfc_current_ns);
4396 gfc_current_ns->derived_types = gfc_derived_types;
4397 gfc_derived_types = NULL;
4398 }
4399 }
4400
4401
4402 static void
4403 clean_up_modules (gfc_gsymbol *gsym)
4404 {
4405 if (gsym == NULL)
4406 return;
4407
4408 clean_up_modules (gsym->left);
4409 clean_up_modules (gsym->right);
4410
4411 if (gsym->type != GSYM_MODULE || !gsym->ns)
4412 return;
4413
4414 gfc_current_ns = gsym->ns;
4415 gfc_derived_types = gfc_current_ns->derived_types;
4416 gfc_done_2 ();
4417 gsym->ns = NULL;
4418 return;
4419 }
4420
4421
4422 /* Translate all the program units when whole file scope option
4423 is active. This could be in a different order to resolution if
4424 there are forward references in the file. */
4425 static void
4426 translate_all_program_units (gfc_namespace *gfc_global_ns_list,
4427 bool main_in_tu)
4428 {
4429 int errors;
4430
4431 gfc_current_ns = gfc_global_ns_list;
4432 gfc_get_errors (NULL, &errors);
4433
4434 /* If the main program is in the translation unit and we have
4435 -fcoarray=libs, generate the static variables. */
4436 if (gfc_option.coarray == GFC_FCOARRAY_LIB && main_in_tu)
4437 gfc_init_coarray_decl (true);
4438
4439 /* We first translate all modules to make sure that later parts
4440 of the program can use the decl. Then we translate the nonmodules. */
4441
4442 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4443 {
4444 if (!gfc_current_ns->proc_name
4445 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4446 continue;
4447
4448 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4449 gfc_derived_types = gfc_current_ns->derived_types;
4450 gfc_generate_module_code (gfc_current_ns);
4451 gfc_current_ns->translated = 1;
4452 }
4453
4454 gfc_current_ns = gfc_global_ns_list;
4455 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4456 {
4457 if (gfc_current_ns->proc_name
4458 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4459 continue;
4460
4461 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4462 gfc_derived_types = gfc_current_ns->derived_types;
4463 gfc_generate_code (gfc_current_ns);
4464 gfc_current_ns->translated = 1;
4465 }
4466
4467 /* Clean up all the namespaces after translation. */
4468 gfc_current_ns = gfc_global_ns_list;
4469 for (;gfc_current_ns;)
4470 {
4471 gfc_namespace *ns;
4472
4473 if (gfc_current_ns->proc_name
4474 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4475 {
4476 gfc_current_ns = gfc_current_ns->sibling;
4477 continue;
4478 }
4479
4480 ns = gfc_current_ns->sibling;
4481 gfc_derived_types = gfc_current_ns->derived_types;
4482 gfc_done_2 ();
4483 gfc_current_ns = ns;
4484 }
4485
4486 clean_up_modules (gfc_gsym_root);
4487 }
4488
4489
4490 /* Top level parser. */
4491
4492 gfc_try
4493 gfc_parse_file (void)
4494 {
4495 int seen_program, errors_before, errors;
4496 gfc_state_data top, s;
4497 gfc_statement st;
4498 locus prog_locus;
4499 gfc_namespace *next;
4500
4501 gfc_start_source_files ();
4502
4503 top.state = COMP_NONE;
4504 top.sym = NULL;
4505 top.previous = NULL;
4506 top.head = top.tail = NULL;
4507 top.do_variable = NULL;
4508
4509 gfc_state_stack = &top;
4510
4511 gfc_clear_new_st ();
4512
4513 gfc_statement_label = NULL;
4514
4515 if (setjmp (eof_buf))
4516 return FAILURE; /* Come here on unexpected EOF */
4517
4518 /* Prepare the global namespace that will contain the
4519 program units. */
4520 gfc_global_ns_list = next = NULL;
4521
4522 seen_program = 0;
4523 errors_before = 0;
4524
4525 /* Exit early for empty files. */
4526 if (gfc_at_eof ())
4527 goto done;
4528
4529 loop:
4530 gfc_init_2 ();
4531 st = next_statement ();
4532 switch (st)
4533 {
4534 case ST_NONE:
4535 gfc_done_2 ();
4536 goto done;
4537
4538 case ST_PROGRAM:
4539 if (seen_program)
4540 goto duplicate_main;
4541 seen_program = 1;
4542 prog_locus = gfc_current_locus;
4543
4544 push_state (&s, COMP_PROGRAM, gfc_new_block);
4545 main_program_symbol(gfc_current_ns, gfc_new_block->name);
4546 accept_statement (st);
4547 add_global_program ();
4548 parse_progunit (ST_NONE);
4549 if (gfc_option.flag_whole_file)
4550 goto prog_units;
4551 break;
4552
4553 case ST_SUBROUTINE:
4554 add_global_procedure (1);
4555 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4556 accept_statement (st);
4557 parse_progunit (ST_NONE);
4558 if (gfc_option.flag_whole_file)
4559 goto prog_units;
4560 break;
4561
4562 case ST_FUNCTION:
4563 add_global_procedure (0);
4564 push_state (&s, COMP_FUNCTION, gfc_new_block);
4565 accept_statement (st);
4566 parse_progunit (ST_NONE);
4567 if (gfc_option.flag_whole_file)
4568 goto prog_units;
4569 break;
4570
4571 case ST_BLOCK_DATA:
4572 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4573 accept_statement (st);
4574 parse_block_data ();
4575 break;
4576
4577 case ST_MODULE:
4578 push_state (&s, COMP_MODULE, gfc_new_block);
4579 accept_statement (st);
4580
4581 gfc_get_errors (NULL, &errors_before);
4582 parse_module ();
4583 break;
4584
4585 /* Anything else starts a nameless main program block. */
4586 default:
4587 if (seen_program)
4588 goto duplicate_main;
4589 seen_program = 1;
4590 prog_locus = gfc_current_locus;
4591
4592 push_state (&s, COMP_PROGRAM, gfc_new_block);
4593 main_program_symbol (gfc_current_ns, "MAIN__");
4594 parse_progunit (st);
4595 if (gfc_option.flag_whole_file)
4596 goto prog_units;
4597 break;
4598 }
4599
4600 /* Handle the non-program units. */
4601 gfc_current_ns->code = s.head;
4602
4603 gfc_resolve (gfc_current_ns);
4604
4605 /* Dump the parse tree if requested. */
4606 if (gfc_option.dump_fortran_original)
4607 gfc_dump_parse_tree (gfc_current_ns, stdout);
4608
4609 gfc_get_errors (NULL, &errors);
4610 if (s.state == COMP_MODULE)
4611 {
4612 gfc_dump_module (s.sym->name, errors_before == errors);
4613 if (!gfc_option.flag_whole_file)
4614 {
4615 if (errors == 0)
4616 gfc_generate_module_code (gfc_current_ns);
4617 pop_state ();
4618 gfc_done_2 ();
4619 }
4620 else
4621 {
4622 gfc_current_ns->derived_types = gfc_derived_types;
4623 gfc_derived_types = NULL;
4624 goto prog_units;
4625 }
4626 }
4627 else
4628 {
4629 if (errors == 0)
4630 gfc_generate_code (gfc_current_ns);
4631 pop_state ();
4632 gfc_done_2 ();
4633 }
4634
4635 goto loop;
4636
4637 prog_units:
4638 /* The main program and non-contained procedures are put
4639 in the global namespace list, so that they can be processed
4640 later and all their interfaces resolved. */
4641 gfc_current_ns->code = s.head;
4642 if (next)
4643 {
4644 for (; next->sibling; next = next->sibling)
4645 ;
4646 next->sibling = gfc_current_ns;
4647 }
4648 else
4649 gfc_global_ns_list = gfc_current_ns;
4650
4651 next = gfc_current_ns;
4652
4653 pop_state ();
4654 goto loop;
4655
4656 done:
4657
4658 if (!gfc_option.flag_whole_file)
4659 goto termination;
4660
4661 /* Do the resolution. */
4662 resolve_all_program_units (gfc_global_ns_list);
4663
4664 /* Do the parse tree dump. */
4665 gfc_current_ns
4666 = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
4667
4668 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4669 if (!gfc_current_ns->proc_name
4670 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4671 {
4672 gfc_dump_parse_tree (gfc_current_ns, stdout);
4673 fputs ("------------------------------------------\n\n", stdout);
4674 }
4675
4676 /* Do the translation. */
4677 translate_all_program_units (gfc_global_ns_list, seen_program);
4678
4679 termination:
4680
4681 gfc_end_source_files ();
4682 return SUCCESS;
4683
4684 duplicate_main:
4685 /* If we see a duplicate main program, shut down. If the second
4686 instance is an implied main program, i.e. data decls or executable
4687 statements, we're in for lots of errors. */
4688 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4689 reject_statement ();
4690 gfc_done_2 ();
4691 return SUCCESS;
4692 }