?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* g++.dg/other/unused1.C: Skip on AIX.
[official-gcc.git] / gcc / fortran / parse.c
blobf31e30940b8ee655b14f8d2327627a544a69e407
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->attr.pointer
2199 && c->ts.u.derived->attr.alloc_comp))
2200 {
2201 allocatable = true;
2202 sym->attr.alloc_comp = 1;
2203 }
2204
2205 /* Look for pointer components. */
2206 if (c->attr.pointer
2207 || (c->ts.type == BT_CLASS && c->attr.class_ok
2208 && CLASS_DATA (c)->attr.class_pointer)
2209 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2210 {
2211 pointer = true;
2212 sym->attr.pointer_comp = 1;
2213 }
2214
2215 /* Look for procedure pointer components. */
2216 if (c->attr.proc_pointer
2217 || (c->ts.type == BT_DERIVED
2218 && c->ts.u.derived->attr.proc_pointer_comp))
2219 sym->attr.proc_pointer_comp = 1;
2220
2221 /* Looking for coarray components. */
2222 if (c->attr.codimension
2223 || (c->ts.type == BT_CLASS && c->attr.class_ok
2224 && CLASS_DATA (c)->attr.codimension))
2225 {
2226 coarray = true;
2227 sym->attr.coarray_comp = 1;
2228 }
2229
2230 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp)
2231 {
2232 coarray = true;
2233 if (!pointer && !allocatable)
2234 sym->attr.coarray_comp = 1;
2235 }
2236
2237 /* Looking for lock_type components. */
2238 if ((c->ts.type == BT_DERIVED
2239 && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
2240 && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
2241 || (c->ts.type == BT_CLASS && c->attr.class_ok
2242 && CLASS_DATA (c)->ts.u.derived->from_intmod
2243 == INTMOD_ISO_FORTRAN_ENV
2244 && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
2245 == ISOFORTRAN_LOCK_TYPE)
2246 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
2247 && !allocatable && !pointer))
2248 {
2249 lock_type = 1;
2250 lock_comp = c;
2251 sym->attr.lock_comp = 1;
2252 }
2253
2254 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2255 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2256 unless there are nondirect [allocatable or pointer] components
2257 involved (cf. 1.3.33.1 and 1.3.33.3). */
2258
2259 if (pointer && !coarray && lock_type)
2260 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2261 "codimension or be a subcomponent of a coarray, "
2262 "which is not possible as the component has the "
2263 "pointer attribute", c->name, &c->loc);
2264 else if (pointer && !coarray && c->ts.type == BT_DERIVED
2265 && c->ts.u.derived->attr.lock_comp)
2266 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2267 "of type LOCK_TYPE, which must have a codimension or be a "
2268 "subcomponent of a coarray", c->name, &c->loc);
2269
2270 if (lock_type && allocatable && !coarray)
2271 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2272 "a codimension", c->name, &c->loc);
2273 else if (lock_type && allocatable && c->ts.type == BT_DERIVED
2274 && c->ts.u.derived->attr.lock_comp)
2275 gfc_error ("Allocatable component %s at %L must have a codimension as "
2276 "it has a noncoarray subcomponent of type LOCK_TYPE",
2277 c->name, &c->loc);
2278
2279 if (sym->attr.coarray_comp && !coarray && lock_type)
2280 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2281 "subcomponent of type LOCK_TYPE must have a codimension or "
2282 "be a subcomponent of a coarray. (Variables of type %s may "
2283 "not have a codimension as already a coarray "
2284 "subcomponent exists)", c->name, &c->loc, sym->name);
2285
2286 if (sym->attr.lock_comp && coarray && !lock_type)
2287 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2288 "subcomponent of type LOCK_TYPE must have a codimension or "
2289 "be a subcomponent of a coarray. (Variables of type %s may "
2290 "not have a codimension as %s at %L has a codimension or a "
2291 "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
2292 sym->name, c->name, &c->loc);
2293
2294 /* Look for private components. */
2295 if (sym->component_access == ACCESS_PRIVATE
2296 || c->attr.access == ACCESS_PRIVATE
2297 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2298 sym->attr.private_comp = 1;
2299 }
2300
2301 if (!seen_component)
2302 sym->attr.zero_comp = 1;
2303
2304 pop_state ();
2305 }
2306
2307
2308 /* Parse an ENUM. */
2309
2310 static void
2311 parse_enum (void)
2312 {
2313 gfc_statement st;
2314 int compiling_enum;
2315 gfc_state_data s;
2316 int seen_enumerator = 0;
2317
2318 push_state (&s, COMP_ENUM, gfc_new_block);
2319
2320 compiling_enum = 1;
2321
2322 while (compiling_enum)
2323 {
2324 st = next_statement ();
2325 switch (st)
2326 {
2327 case ST_NONE:
2328 unexpected_eof ();
2329 break;
2330
2331 case ST_ENUMERATOR:
2332 seen_enumerator = 1;
2333 accept_statement (st);
2334 break;
2335
2336 case ST_END_ENUM:
2337 compiling_enum = 0;
2338 if (!seen_enumerator)
2339 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2340 accept_statement (st);
2341 break;
2342
2343 default:
2344 gfc_free_enum_history ();
2345 unexpected_statement (st);
2346 break;
2347 }
2348 }
2349 pop_state ();
2350 }
2351
2352
2353 /* Parse an interface. We must be able to deal with the possibility
2354 of recursive interfaces. The parse_spec() subroutine is mutually
2355 recursive with parse_interface(). */
2356
2357 static gfc_statement parse_spec (gfc_statement);
2358
2359 static void
2360 parse_interface (void)
2361 {
2362 gfc_compile_state new_state = COMP_NONE, current_state;
2363 gfc_symbol *prog_unit, *sym;
2364 gfc_interface_info save;
2365 gfc_state_data s1, s2;
2366 gfc_statement st;
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 if (prog_unit == prog_unit->formal_ns->proc_name
2456 && prog_unit->ns != prog_unit->formal_ns)
2457 prog_unit->refs++;
2458
2459 decl:
2460 /* Read data declaration statements. */
2461 st = parse_spec (ST_NONE);
2462
2463 /* Since the interface block does not permit an IMPLICIT statement,
2464 the default type for the function or the result must be taken
2465 from the formal namespace. */
2466 if (new_state == COMP_FUNCTION)
2467 {
2468 if (prog_unit->result == prog_unit
2469 && prog_unit->ts.type == BT_UNKNOWN)
2470 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2471 else if (prog_unit->result != prog_unit
2472 && prog_unit->result->ts.type == BT_UNKNOWN)
2473 gfc_set_default_type (prog_unit->result, 1,
2474 prog_unit->formal_ns);
2475 }
2476
2477 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2478 {
2479 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2480 gfc_ascii_statement (st));
2481 reject_statement ();
2482 goto decl;
2483 }
2484
2485 /* Add EXTERNAL attribute to function or subroutine. */
2486 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2487 gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2488
2489 current_interface = save;
2490 gfc_add_interface (prog_unit);
2491 pop_state ();
2492
2493 if (current_interface.ns
2494 && current_interface.ns->proc_name
2495 && strcmp (current_interface.ns->proc_name->name,
2496 prog_unit->name) == 0)
2497 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2498 "enclosing procedure", prog_unit->name,
2499 &current_interface.ns->proc_name->declared_at);
2500
2501 goto loop;
2502
2503 done:
2504 pop_state ();
2505 }
2506
2507
2508 /* Associate function characteristics by going back to the function
2509 declaration and rematching the prefix. */
2510
2511 static match
2512 match_deferred_characteristics (gfc_typespec * ts)
2513 {
2514 locus loc;
2515 match m = MATCH_ERROR;
2516 char name[GFC_MAX_SYMBOL_LEN + 1];
2517
2518 loc = gfc_current_locus;
2519
2520 gfc_current_locus = gfc_current_block ()->declared_at;
2521
2522 gfc_clear_error ();
2523 gfc_buffer_error (1);
2524 m = gfc_match_prefix (ts);
2525 gfc_buffer_error (0);
2526
2527 if (ts->type == BT_DERIVED)
2528 {
2529 ts->kind = 0;
2530
2531 if (!ts->u.derived)
2532 m = MATCH_ERROR;
2533 }
2534
2535 /* Only permit one go at the characteristic association. */
2536 if (ts->kind == -1)
2537 ts->kind = 0;
2538
2539 /* Set the function locus correctly. If we have not found the
2540 function name, there is an error. */
2541 if (m == MATCH_YES
2542 && gfc_match ("function% %n", name) == MATCH_YES
2543 && strcmp (name, gfc_current_block ()->name) == 0)
2544 {
2545 gfc_current_block ()->declared_at = gfc_current_locus;
2546 gfc_commit_symbols ();
2547 }
2548 else
2549 {
2550 gfc_error_check ();
2551 gfc_undo_symbols ();
2552 }
2553
2554 gfc_current_locus =loc;
2555 return m;
2556 }
2557
2558
2559 /* Check specification-expressions in the function result of the currently
2560 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2561 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2562 scope are not yet parsed so this has to be delayed up to parse_spec. */
2563
2564 static void
2565 check_function_result_typed (void)
2566 {
2567 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2568
2569 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2570 gcc_assert (ts->type != BT_UNKNOWN);
2571
2572 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2573 /* TODO: Extend when KIND type parameters are implemented. */
2574 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2575 gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2576 }
2577
2578
2579 /* Parse a set of specification statements. Returns the statement
2580 that doesn't fit. */
2581
2582 static gfc_statement
2583 parse_spec (gfc_statement st)
2584 {
2585 st_state ss;
2586 bool function_result_typed = false;
2587 bool bad_characteristic = false;
2588 gfc_typespec *ts;
2589
2590 verify_st_order (&ss, ST_NONE, false);
2591 if (st == ST_NONE)
2592 st = next_statement ();
2593
2594 /* If we are not inside a function or don't have a result specified so far,
2595 do nothing special about it. */
2596 if (gfc_current_state () != COMP_FUNCTION)
2597 function_result_typed = true;
2598 else
2599 {
2600 gfc_symbol* proc = gfc_current_ns->proc_name;
2601 gcc_assert (proc);
2602
2603 if (proc->result->ts.type == BT_UNKNOWN)
2604 function_result_typed = true;
2605 }
2606
2607 loop:
2608
2609 /* If we're inside a BLOCK construct, some statements are disallowed.
2610 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2611 or VALUE are also disallowed, but they don't have a particular ST_*
2612 key so we have to check for them individually in their matcher routine. */
2613 if (gfc_current_state () == COMP_BLOCK)
2614 switch (st)
2615 {
2616 case ST_IMPLICIT:
2617 case ST_IMPLICIT_NONE:
2618 case ST_NAMELIST:
2619 case ST_COMMON:
2620 case ST_EQUIVALENCE:
2621 case ST_STATEMENT_FUNCTION:
2622 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2623 gfc_ascii_statement (st));
2624 reject_statement ();
2625 break;
2626
2627 default:
2628 break;
2629 }
2630
2631 /* If we find a statement that can not be followed by an IMPLICIT statement
2632 (and thus we can expect to see none any further), type the function result
2633 if it has not yet been typed. Be careful not to give the END statement
2634 to verify_st_order! */
2635 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2636 {
2637 bool verify_now = false;
2638
2639 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2640 verify_now = true;
2641 else
2642 {
2643 st_state dummyss;
2644 verify_st_order (&dummyss, ST_NONE, false);
2645 verify_st_order (&dummyss, st, false);
2646
2647 if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2648 verify_now = true;
2649 }
2650
2651 if (verify_now)
2652 {
2653 check_function_result_typed ();
2654 function_result_typed = true;
2655 }
2656 }
2657
2658 switch (st)
2659 {
2660 case ST_NONE:
2661 unexpected_eof ();
2662
2663 case ST_IMPLICIT_NONE:
2664 case ST_IMPLICIT:
2665 if (!function_result_typed)
2666 {
2667 check_function_result_typed ();
2668 function_result_typed = true;
2669 }
2670 goto declSt;
2671
2672 case ST_FORMAT:
2673 case ST_ENTRY:
2674 case ST_DATA: /* Not allowed in interfaces */
2675 if (gfc_current_state () == COMP_INTERFACE)
2676 break;
2677
2678 /* Fall through */
2679
2680 case ST_USE:
2681 case ST_IMPORT:
2682 case ST_PARAMETER:
2683 case ST_PUBLIC:
2684 case ST_PRIVATE:
2685 case ST_DERIVED_DECL:
2686 case_decl:
2687 declSt:
2688 if (verify_st_order (&ss, st, false) == FAILURE)
2689 {
2690 reject_statement ();
2691 st = next_statement ();
2692 goto loop;
2693 }
2694
2695 switch (st)
2696 {
2697 case ST_INTERFACE:
2698 parse_interface ();
2699 break;
2700
2701 case ST_DERIVED_DECL:
2702 parse_derived ();
2703 break;
2704
2705 case ST_PUBLIC:
2706 case ST_PRIVATE:
2707 if (gfc_current_state () != COMP_MODULE)
2708 {
2709 gfc_error ("%s statement must appear in a MODULE",
2710 gfc_ascii_statement (st));
2711 reject_statement ();
2712 break;
2713 }
2714
2715 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2716 {
2717 gfc_error ("%s statement at %C follows another accessibility "
2718 "specification", gfc_ascii_statement (st));
2719 reject_statement ();
2720 break;
2721 }
2722
2723 gfc_current_ns->default_access = (st == ST_PUBLIC)
2724 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2725
2726 break;
2727
2728 case ST_STATEMENT_FUNCTION:
2729 if (gfc_current_state () == COMP_MODULE)
2730 {
2731 unexpected_statement (st);
2732 break;
2733 }
2734
2735 default:
2736 break;
2737 }
2738
2739 accept_statement (st);
2740 st = next_statement ();
2741 goto loop;
2742
2743 case ST_ENUM:
2744 accept_statement (st);
2745 parse_enum();
2746 st = next_statement ();
2747 goto loop;
2748
2749 case ST_GET_FCN_CHARACTERISTICS:
2750 /* This statement triggers the association of a function's result
2751 characteristics. */
2752 ts = &gfc_current_block ()->result->ts;
2753 if (match_deferred_characteristics (ts) != MATCH_YES)
2754 bad_characteristic = true;
2755
2756 st = next_statement ();
2757 goto loop;
2758
2759 default:
2760 break;
2761 }
2762
2763 /* If match_deferred_characteristics failed, then there is an error. */
2764 if (bad_characteristic)
2765 {
2766 ts = &gfc_current_block ()->result->ts;
2767 if (ts->type != BT_DERIVED)
2768 gfc_error ("Bad kind expression for function '%s' at %L",
2769 gfc_current_block ()->name,
2770 &gfc_current_block ()->declared_at);
2771 else
2772 gfc_error ("The type for function '%s' at %L is not accessible",
2773 gfc_current_block ()->name,
2774 &gfc_current_block ()->declared_at);
2775
2776 gfc_current_block ()->ts.kind = 0;
2777 /* Keep the derived type; if it's bad, it will be discovered later. */
2778 if (!(ts->type == BT_DERIVED && ts->u.derived))
2779 ts->type = BT_UNKNOWN;
2780 }
2781
2782 return st;
2783 }
2784
2785
2786 /* Parse a WHERE block, (not a simple WHERE statement). */
2787
2788 static void
2789 parse_where_block (void)
2790 {
2791 int seen_empty_else;
2792 gfc_code *top, *d;
2793 gfc_state_data s;
2794 gfc_statement st;
2795
2796 accept_statement (ST_WHERE_BLOCK);
2797 top = gfc_state_stack->tail;
2798
2799 push_state (&s, COMP_WHERE, gfc_new_block);
2800
2801 d = add_statement ();
2802 d->expr1 = top->expr1;
2803 d->op = EXEC_WHERE;
2804
2805 top->expr1 = NULL;
2806 top->block = d;
2807
2808 seen_empty_else = 0;
2809
2810 do
2811 {
2812 st = next_statement ();
2813 switch (st)
2814 {
2815 case ST_NONE:
2816 unexpected_eof ();
2817
2818 case ST_WHERE_BLOCK:
2819 parse_where_block ();
2820 break;
2821
2822 case ST_ASSIGNMENT:
2823 case ST_WHERE:
2824 accept_statement (st);
2825 break;
2826
2827 case ST_ELSEWHERE:
2828 if (seen_empty_else)
2829 {
2830 gfc_error ("ELSEWHERE statement at %C follows previous "
2831 "unmasked ELSEWHERE");
2832 reject_statement ();
2833 break;
2834 }
2835
2836 if (new_st.expr1 == NULL)
2837 seen_empty_else = 1;
2838
2839 d = new_level (gfc_state_stack->head);
2840 d->op = EXEC_WHERE;
2841 d->expr1 = new_st.expr1;
2842
2843 accept_statement (st);
2844
2845 break;
2846
2847 case ST_END_WHERE:
2848 accept_statement (st);
2849 break;
2850
2851 default:
2852 gfc_error ("Unexpected %s statement in WHERE block at %C",
2853 gfc_ascii_statement (st));
2854 reject_statement ();
2855 break;
2856 }
2857 }
2858 while (st != ST_END_WHERE);
2859
2860 pop_state ();
2861 }
2862
2863
2864 /* Parse a FORALL block (not a simple FORALL statement). */
2865
2866 static void
2867 parse_forall_block (void)
2868 {
2869 gfc_code *top, *d;
2870 gfc_state_data s;
2871 gfc_statement st;
2872
2873 accept_statement (ST_FORALL_BLOCK);
2874 top = gfc_state_stack->tail;
2875
2876 push_state (&s, COMP_FORALL, gfc_new_block);
2877
2878 d = add_statement ();
2879 d->op = EXEC_FORALL;
2880 top->block = d;
2881
2882 do
2883 {
2884 st = next_statement ();
2885 switch (st)
2886 {
2887
2888 case ST_ASSIGNMENT:
2889 case ST_POINTER_ASSIGNMENT:
2890 case ST_WHERE:
2891 case ST_FORALL:
2892 accept_statement (st);
2893 break;
2894
2895 case ST_WHERE_BLOCK:
2896 parse_where_block ();
2897 break;
2898
2899 case ST_FORALL_BLOCK:
2900 parse_forall_block ();
2901 break;
2902
2903 case ST_END_FORALL:
2904 accept_statement (st);
2905 break;
2906
2907 case ST_NONE:
2908 unexpected_eof ();
2909
2910 default:
2911 gfc_error ("Unexpected %s statement in FORALL block at %C",
2912 gfc_ascii_statement (st));
2913
2914 reject_statement ();
2915 break;
2916 }
2917 }
2918 while (st != ST_END_FORALL);
2919
2920 pop_state ();
2921 }
2922
2923
2924 static gfc_statement parse_executable (gfc_statement);
2925
2926 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2927
2928 static void
2929 parse_if_block (void)
2930 {
2931 gfc_code *top, *d;
2932 gfc_statement st;
2933 locus else_locus;
2934 gfc_state_data s;
2935 int seen_else;
2936
2937 seen_else = 0;
2938 accept_statement (ST_IF_BLOCK);
2939
2940 top = gfc_state_stack->tail;
2941 push_state (&s, COMP_IF, gfc_new_block);
2942
2943 new_st.op = EXEC_IF;
2944 d = add_statement ();
2945
2946 d->expr1 = top->expr1;
2947 top->expr1 = NULL;
2948 top->block = d;
2949
2950 do
2951 {
2952 st = parse_executable (ST_NONE);
2953
2954 switch (st)
2955 {
2956 case ST_NONE:
2957 unexpected_eof ();
2958
2959 case ST_ELSEIF:
2960 if (seen_else)
2961 {
2962 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2963 "statement at %L", &else_locus);
2964
2965 reject_statement ();
2966 break;
2967 }
2968
2969 d = new_level (gfc_state_stack->head);
2970 d->op = EXEC_IF;
2971 d->expr1 = new_st.expr1;
2972
2973 accept_statement (st);
2974
2975 break;
2976
2977 case ST_ELSE:
2978 if (seen_else)
2979 {
2980 gfc_error ("Duplicate ELSE statements at %L and %C",
2981 &else_locus);
2982 reject_statement ();
2983 break;
2984 }
2985
2986 seen_else = 1;
2987 else_locus = gfc_current_locus;
2988
2989 d = new_level (gfc_state_stack->head);
2990 d->op = EXEC_IF;
2991
2992 accept_statement (st);
2993
2994 break;
2995
2996 case ST_ENDIF:
2997 break;
2998
2999 default:
3000 unexpected_statement (st);
3001 break;
3002 }
3003 }
3004 while (st != ST_ENDIF);
3005
3006 pop_state ();
3007 accept_statement (st);
3008 }
3009
3010
3011 /* Parse a SELECT block. */
3012
3013 static void
3014 parse_select_block (void)
3015 {
3016 gfc_statement st;
3017 gfc_code *cp;
3018 gfc_state_data s;
3019
3020 accept_statement (ST_SELECT_CASE);
3021
3022 cp = gfc_state_stack->tail;
3023 push_state (&s, COMP_SELECT, gfc_new_block);
3024
3025 /* Make sure that the next statement is a CASE or END SELECT. */
3026 for (;;)
3027 {
3028 st = next_statement ();
3029 if (st == ST_NONE)
3030 unexpected_eof ();
3031 if (st == ST_END_SELECT)
3032 {
3033 /* Empty SELECT CASE is OK. */
3034 accept_statement (st);
3035 pop_state ();
3036 return;
3037 }
3038 if (st == ST_CASE)
3039 break;
3040
3041 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3042 "CASE at %C");
3043
3044 reject_statement ();
3045 }
3046
3047 /* At this point, we're got a nonempty select block. */
3048 cp = new_level (cp);
3049 *cp = new_st;
3050
3051 accept_statement (st);
3052
3053 do
3054 {
3055 st = parse_executable (ST_NONE);
3056 switch (st)
3057 {
3058 case ST_NONE:
3059 unexpected_eof ();
3060
3061 case ST_CASE:
3062 cp = new_level (gfc_state_stack->head);
3063 *cp = new_st;
3064 gfc_clear_new_st ();
3065
3066 accept_statement (st);
3067 /* Fall through */
3068
3069 case ST_END_SELECT:
3070 break;
3071
3072 /* Can't have an executable statement because of
3073 parse_executable(). */
3074 default:
3075 unexpected_statement (st);
3076 break;
3077 }
3078 }
3079 while (st != ST_END_SELECT);
3080
3081 pop_state ();
3082 accept_statement (st);
3083 }
3084
3085
3086 /* Pop the current selector from the SELECT TYPE stack. */
3087
3088 static void
3089 select_type_pop (void)
3090 {
3091 gfc_select_type_stack *old = select_type_stack;
3092 select_type_stack = old->prev;
3093 free (old);
3094 }
3095
3096
3097 /* Parse a SELECT TYPE construct (F03:R821). */
3098
3099 static void
3100 parse_select_type_block (void)
3101 {
3102 gfc_statement st;
3103 gfc_code *cp;
3104 gfc_state_data s;
3105
3106 accept_statement (ST_SELECT_TYPE);
3107
3108 cp = gfc_state_stack->tail;
3109 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
3110
3111 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3112 or END SELECT. */
3113 for (;;)
3114 {
3115 st = next_statement ();
3116 if (st == ST_NONE)
3117 unexpected_eof ();
3118 if (st == ST_END_SELECT)
3119 /* Empty SELECT CASE is OK. */
3120 goto done;
3121 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
3122 break;
3123
3124 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3125 "following SELECT TYPE at %C");
3126
3127 reject_statement ();
3128 }
3129
3130 /* At this point, we're got a nonempty select block. */
3131 cp = new_level (cp);
3132 *cp = new_st;
3133
3134 accept_statement (st);
3135
3136 do
3137 {
3138 st = parse_executable (ST_NONE);
3139 switch (st)
3140 {
3141 case ST_NONE:
3142 unexpected_eof ();
3143
3144 case ST_TYPE_IS:
3145 case ST_CLASS_IS:
3146 cp = new_level (gfc_state_stack->head);
3147 *cp = new_st;
3148 gfc_clear_new_st ();
3149
3150 accept_statement (st);
3151 /* Fall through */
3152
3153 case ST_END_SELECT:
3154 break;
3155
3156 /* Can't have an executable statement because of
3157 parse_executable(). */
3158 default:
3159 unexpected_statement (st);
3160 break;
3161 }
3162 }
3163 while (st != ST_END_SELECT);
3164
3165 done:
3166 pop_state ();
3167 accept_statement (st);
3168 gfc_current_ns = gfc_current_ns->parent;
3169 select_type_pop ();
3170 }
3171
3172
3173 /* Given a symbol, make sure it is not an iteration variable for a DO
3174 statement. This subroutine is called when the symbol is seen in a
3175 context that causes it to become redefined. If the symbol is an
3176 iterator, we generate an error message and return nonzero. */
3177
3178 int
3179 gfc_check_do_variable (gfc_symtree *st)
3180 {
3181 gfc_state_data *s;
3182
3183 for (s=gfc_state_stack; s; s = s->previous)
3184 if (s->do_variable == st)
3185 {
3186 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3187 "loop beginning at %L", st->name, &s->head->loc);
3188 return 1;
3189 }
3190
3191 return 0;
3192 }
3193
3194
3195 /* Checks to see if the current statement label closes an enddo.
3196 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3197 an error) if it incorrectly closes an ENDDO. */
3198
3199 static int
3200 check_do_closure (void)
3201 {
3202 gfc_state_data *p;
3203
3204 if (gfc_statement_label == NULL)
3205 return 0;
3206
3207 for (p = gfc_state_stack; p; p = p->previous)
3208 if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3209 break;
3210
3211 if (p == NULL)
3212 return 0; /* No loops to close */
3213
3214 if (p->ext.end_do_label == gfc_statement_label)
3215 {
3216 if (p == gfc_state_stack)
3217 return 1;
3218
3219 gfc_error ("End of nonblock DO statement at %C is within another block");
3220 return 2;
3221 }
3222
3223 /* At this point, the label doesn't terminate the innermost loop.
3224 Make sure it doesn't terminate another one. */
3225 for (; p; p = p->previous)
3226 if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
3227 && p->ext.end_do_label == gfc_statement_label)
3228 {
3229 gfc_error ("End of nonblock DO statement at %C is interwoven "
3230 "with another DO loop");
3231 return 2;
3232 }
3233
3234 return 0;
3235 }
3236
3237
3238 /* Parse a series of contained program units. */
3239
3240 static void parse_progunit (gfc_statement);
3241
3242
3243 /* Parse a CRITICAL block. */
3244
3245 static void
3246 parse_critical_block (void)
3247 {
3248 gfc_code *top, *d;
3249 gfc_state_data s;
3250 gfc_statement st;
3251
3252 s.ext.end_do_label = new_st.label1;
3253
3254 accept_statement (ST_CRITICAL);
3255 top = gfc_state_stack->tail;
3256
3257 push_state (&s, COMP_CRITICAL, gfc_new_block);
3258
3259 d = add_statement ();
3260 d->op = EXEC_CRITICAL;
3261 top->block = d;
3262
3263 do
3264 {
3265 st = parse_executable (ST_NONE);
3266
3267 switch (st)
3268 {
3269 case ST_NONE:
3270 unexpected_eof ();
3271 break;
3272
3273 case ST_END_CRITICAL:
3274 if (s.ext.end_do_label != NULL
3275 && s.ext.end_do_label != gfc_statement_label)
3276 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3277 "match CRITICAL label");
3278
3279 if (gfc_statement_label != NULL)
3280 {
3281 new_st.op = EXEC_NOP;
3282 add_statement ();
3283 }
3284 break;
3285
3286 default:
3287 unexpected_statement (st);
3288 break;
3289 }
3290 }
3291 while (st != ST_END_CRITICAL);
3292
3293 pop_state ();
3294 accept_statement (st);
3295 }
3296
3297
3298 /* Set up the local namespace for a BLOCK construct. */
3299
3300 gfc_namespace*
3301 gfc_build_block_ns (gfc_namespace *parent_ns)
3302 {
3303 gfc_namespace* my_ns;
3304 static int numblock = 1;
3305
3306 my_ns = gfc_get_namespace (parent_ns, 1);
3307 my_ns->construct_entities = 1;
3308
3309 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3310 code generation (so it must not be NULL).
3311 We set its recursive argument if our container procedure is recursive, so
3312 that local variables are accordingly placed on the stack when it
3313 will be necessary. */
3314 if (gfc_new_block)
3315 my_ns->proc_name = gfc_new_block;
3316 else
3317 {
3318 gfc_try t;
3319 char buffer[20]; /* Enough to hold "block@2147483648\n". */
3320
3321 snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
3322 gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
3323 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3324 my_ns->proc_name->name, NULL);
3325 gcc_assert (t == SUCCESS);
3326 gfc_commit_symbol (my_ns->proc_name);
3327 }
3328
3329 if (parent_ns->proc_name)
3330 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3331
3332 return my_ns;
3333 }
3334
3335
3336 /* Parse a BLOCK construct. */
3337
3338 static void
3339 parse_block_construct (void)
3340 {
3341 gfc_namespace* my_ns;
3342 gfc_state_data s;
3343
3344 gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
3345
3346 my_ns = gfc_build_block_ns (gfc_current_ns);
3347
3348 new_st.op = EXEC_BLOCK;
3349 new_st.ext.block.ns = my_ns;
3350 new_st.ext.block.assoc = NULL;
3351 accept_statement (ST_BLOCK);
3352
3353 push_state (&s, COMP_BLOCK, my_ns->proc_name);
3354 gfc_current_ns = my_ns;
3355
3356 parse_progunit (ST_NONE);
3357
3358 gfc_current_ns = gfc_current_ns->parent;
3359 pop_state ();
3360 }
3361
3362
3363 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3364 behind the scenes with compiler-generated variables. */
3365
3366 static void
3367 parse_associate (void)
3368 {
3369 gfc_namespace* my_ns;
3370 gfc_state_data s;
3371 gfc_statement st;
3372 gfc_association_list* a;
3373
3374 gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
3375
3376 my_ns = gfc_build_block_ns (gfc_current_ns);
3377
3378 new_st.op = EXEC_BLOCK;
3379 new_st.ext.block.ns = my_ns;
3380 gcc_assert (new_st.ext.block.assoc);
3381
3382 /* Add all associate-names as BLOCK variables. Creating them is enough
3383 for now, they'll get their values during trans-* phase. */
3384 gfc_current_ns = my_ns;
3385 for (a = new_st.ext.block.assoc; a; a = a->next)
3386 {
3387 gfc_symbol* sym;
3388
3389 if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3390 gcc_unreachable ();
3391
3392 sym = a->st->n.sym;
3393 sym->attr.flavor = FL_VARIABLE;
3394 sym->assoc = a;
3395 sym->declared_at = a->where;
3396 gfc_set_sym_referenced (sym);
3397
3398 /* Initialize the typespec. It is not available in all cases,
3399 however, as it may only be set on the target during resolution.
3400 Still, sometimes it helps to have it right now -- especially
3401 for parsing component references on the associate-name
3402 in case of association to a derived-type. */
3403 sym->ts = a->target->ts;
3404 }
3405
3406 accept_statement (ST_ASSOCIATE);
3407 push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3408
3409 loop:
3410 st = parse_executable (ST_NONE);
3411 switch (st)
3412 {
3413 case ST_NONE:
3414 unexpected_eof ();
3415
3416 case_end:
3417 accept_statement (st);
3418 my_ns->code = gfc_state_stack->head;
3419 break;
3420
3421 default:
3422 unexpected_statement (st);
3423 goto loop;
3424 }
3425
3426 gfc_current_ns = gfc_current_ns->parent;
3427 pop_state ();
3428 }
3429
3430
3431 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3432 handled inside of parse_executable(), because they aren't really
3433 loop statements. */
3434
3435 static void
3436 parse_do_block (void)
3437 {
3438 gfc_statement st;
3439 gfc_code *top;
3440 gfc_state_data s;
3441 gfc_symtree *stree;
3442 gfc_exec_op do_op;
3443
3444 do_op = new_st.op;
3445 s.ext.end_do_label = new_st.label1;
3446
3447 if (new_st.ext.iterator != NULL)
3448 stree = new_st.ext.iterator->var->symtree;
3449 else
3450 stree = NULL;
3451
3452 accept_statement (ST_DO);
3453
3454 top = gfc_state_stack->tail;
3455 push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
3456 gfc_new_block);
3457
3458 s.do_variable = stree;
3459
3460 top->block = new_level (top);
3461 top->block->op = EXEC_DO;
3462
3463 loop:
3464 st = parse_executable (ST_NONE);
3465
3466 switch (st)
3467 {
3468 case ST_NONE:
3469 unexpected_eof ();
3470
3471 case ST_ENDDO:
3472 if (s.ext.end_do_label != NULL
3473 && s.ext.end_do_label != gfc_statement_label)
3474 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3475 "DO label");
3476
3477 if (gfc_statement_label != NULL)
3478 {
3479 new_st.op = EXEC_NOP;
3480 add_statement ();
3481 }
3482 break;
3483
3484 case ST_IMPLIED_ENDDO:
3485 /* If the do-stmt of this DO construct has a do-construct-name,
3486 the corresponding end-do must be an end-do-stmt (with a matching
3487 name, but in that case we must have seen ST_ENDDO first).
3488 We only complain about this in pedantic mode. */
3489 if (gfc_current_block () != NULL)
3490 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3491 &gfc_current_block()->declared_at);
3492
3493 break;
3494
3495 default:
3496 unexpected_statement (st);
3497 goto loop;
3498 }
3499
3500 pop_state ();
3501 accept_statement (st);
3502 }
3503
3504
3505 /* Parse the statements of OpenMP do/parallel do. */
3506
3507 static gfc_statement
3508 parse_omp_do (gfc_statement omp_st)
3509 {
3510 gfc_statement st;
3511 gfc_code *cp, *np;
3512 gfc_state_data s;
3513
3514 accept_statement (omp_st);
3515
3516 cp = gfc_state_stack->tail;
3517 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3518 np = new_level (cp);
3519 np->op = cp->op;
3520 np->block = NULL;
3521
3522 for (;;)
3523 {
3524 st = next_statement ();
3525 if (st == ST_NONE)
3526 unexpected_eof ();
3527 else if (st == ST_DO)
3528 break;
3529 else
3530 unexpected_statement (st);
3531 }
3532
3533 parse_do_block ();
3534 if (gfc_statement_label != NULL
3535 && gfc_state_stack->previous != NULL
3536 && gfc_state_stack->previous->state == COMP_DO
3537 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3538 {
3539 /* In
3540 DO 100 I=1,10
3541 !$OMP DO
3542 DO J=1,10
3543 ...
3544 100 CONTINUE
3545 there should be no !$OMP END DO. */
3546 pop_state ();
3547 return ST_IMPLIED_ENDDO;
3548 }
3549
3550 check_do_closure ();
3551 pop_state ();
3552
3553 st = next_statement ();
3554 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3555 {
3556 if (new_st.op == EXEC_OMP_END_NOWAIT)
3557 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3558 else
3559 gcc_assert (new_st.op == EXEC_NOP);
3560 gfc_clear_new_st ();
3561 gfc_commit_symbols ();
3562 gfc_warning_check ();
3563 st = next_statement ();
3564 }
3565 return st;
3566 }
3567
3568
3569 /* Parse the statements of OpenMP atomic directive. */
3570
3571 static gfc_statement
3572 parse_omp_atomic (void)
3573 {
3574 gfc_statement st;
3575 gfc_code *cp, *np;
3576 gfc_state_data s;
3577 int count;
3578
3579 accept_statement (ST_OMP_ATOMIC);
3580
3581 cp = gfc_state_stack->tail;
3582 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3583 np = new_level (cp);
3584 np->op = cp->op;
3585 np->block = NULL;
3586 count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
3587
3588 while (count)
3589 {
3590 st = next_statement ();
3591 if (st == ST_NONE)
3592 unexpected_eof ();
3593 else if (st == ST_ASSIGNMENT)
3594 {
3595 accept_statement (st);
3596 count--;
3597 }
3598 else
3599 unexpected_statement (st);
3600 }
3601
3602 pop_state ();
3603
3604 st = next_statement ();
3605 if (st == ST_OMP_END_ATOMIC)
3606 {
3607 gfc_clear_new_st ();
3608 gfc_commit_symbols ();
3609 gfc_warning_check ();
3610 st = next_statement ();
3611 }
3612 else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
3613 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3614 return st;
3615 }
3616
3617
3618 /* Parse the statements of an OpenMP structured block. */
3619
3620 static void
3621 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3622 {
3623 gfc_statement st, omp_end_st;
3624 gfc_code *cp, *np;
3625 gfc_state_data s;
3626
3627 accept_statement (omp_st);
3628
3629 cp = gfc_state_stack->tail;
3630 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3631 np = new_level (cp);
3632 np->op = cp->op;
3633 np->block = NULL;
3634
3635 switch (omp_st)
3636 {
3637 case ST_OMP_PARALLEL:
3638 omp_end_st = ST_OMP_END_PARALLEL;
3639 break;
3640 case ST_OMP_PARALLEL_SECTIONS:
3641 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3642 break;
3643 case ST_OMP_SECTIONS:
3644 omp_end_st = ST_OMP_END_SECTIONS;
3645 break;
3646 case ST_OMP_ORDERED:
3647 omp_end_st = ST_OMP_END_ORDERED;
3648 break;
3649 case ST_OMP_CRITICAL:
3650 omp_end_st = ST_OMP_END_CRITICAL;
3651 break;
3652 case ST_OMP_MASTER:
3653 omp_end_st = ST_OMP_END_MASTER;
3654 break;
3655 case ST_OMP_SINGLE:
3656 omp_end_st = ST_OMP_END_SINGLE;
3657 break;
3658 case ST_OMP_TASK:
3659 omp_end_st = ST_OMP_END_TASK;
3660 break;
3661 case ST_OMP_WORKSHARE:
3662 omp_end_st = ST_OMP_END_WORKSHARE;
3663 break;
3664 case ST_OMP_PARALLEL_WORKSHARE:
3665 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3666 break;
3667 default:
3668 gcc_unreachable ();
3669 }
3670
3671 do
3672 {
3673 if (workshare_stmts_only)
3674 {
3675 /* Inside of !$omp workshare, only
3676 scalar assignments
3677 array assignments
3678 where statements and constructs
3679 forall statements and constructs
3680 !$omp atomic
3681 !$omp critical
3682 !$omp parallel
3683 are allowed. For !$omp critical these
3684 restrictions apply recursively. */
3685 bool cycle = true;
3686
3687 st = next_statement ();
3688 for (;;)
3689 {
3690 switch (st)
3691 {
3692 case ST_NONE:
3693 unexpected_eof ();
3694
3695 case ST_ASSIGNMENT:
3696 case ST_WHERE:
3697 case ST_FORALL:
3698 accept_statement (st);
3699 break;
3700
3701 case ST_WHERE_BLOCK:
3702 parse_where_block ();
3703 break;
3704
3705 case ST_FORALL_BLOCK:
3706 parse_forall_block ();
3707 break;
3708
3709 case ST_OMP_PARALLEL:
3710 case ST_OMP_PARALLEL_SECTIONS:
3711 parse_omp_structured_block (st, false);
3712 break;
3713
3714 case ST_OMP_PARALLEL_WORKSHARE:
3715 case ST_OMP_CRITICAL:
3716 parse_omp_structured_block (st, true);
3717 break;
3718
3719 case ST_OMP_PARALLEL_DO:
3720 st = parse_omp_do (st);
3721 continue;
3722
3723 case ST_OMP_ATOMIC:
3724 st = parse_omp_atomic ();
3725 continue;
3726
3727 default:
3728 cycle = false;
3729 break;
3730 }
3731
3732 if (!cycle)
3733 break;
3734
3735 st = next_statement ();
3736 }
3737 }
3738 else
3739 st = parse_executable (ST_NONE);
3740 if (st == ST_NONE)
3741 unexpected_eof ();
3742 else if (st == ST_OMP_SECTION
3743 && (omp_st == ST_OMP_SECTIONS
3744 || omp_st == ST_OMP_PARALLEL_SECTIONS))
3745 {
3746 np = new_level (np);
3747 np->op = cp->op;
3748 np->block = NULL;
3749 }
3750 else if (st != omp_end_st)
3751 unexpected_statement (st);
3752 }
3753 while (st != omp_end_st);
3754
3755 switch (new_st.op)
3756 {
3757 case EXEC_OMP_END_NOWAIT:
3758 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3759 break;
3760 case EXEC_OMP_CRITICAL:
3761 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3762 || (new_st.ext.omp_name != NULL
3763 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3764 gfc_error ("Name after !$omp critical and !$omp end critical does "
3765 "not match at %C");
3766 free (CONST_CAST (char *, new_st.ext.omp_name));
3767 break;
3768 case EXEC_OMP_END_SINGLE:
3769 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3770 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3771 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3772 gfc_free_omp_clauses (new_st.ext.omp_clauses);
3773 break;
3774 case EXEC_NOP:
3775 break;
3776 default:
3777 gcc_unreachable ();
3778 }
3779
3780 gfc_clear_new_st ();
3781 gfc_commit_symbols ();
3782 gfc_warning_check ();
3783 pop_state ();
3784 }
3785
3786
3787 /* Accept a series of executable statements. We return the first
3788 statement that doesn't fit to the caller. Any block statements are
3789 passed on to the correct handler, which usually passes the buck
3790 right back here. */
3791
3792 static gfc_statement
3793 parse_executable (gfc_statement st)
3794 {
3795 int close_flag;
3796
3797 if (st == ST_NONE)
3798 st = next_statement ();
3799
3800 for (;;)
3801 {
3802 close_flag = check_do_closure ();
3803 if (close_flag)
3804 switch (st)
3805 {
3806 case ST_GOTO:
3807 case ST_END_PROGRAM:
3808 case ST_RETURN:
3809 case ST_EXIT:
3810 case ST_END_FUNCTION:
3811 case ST_CYCLE:
3812 case ST_PAUSE:
3813 case ST_STOP:
3814 case ST_ERROR_STOP:
3815 case ST_END_SUBROUTINE:
3816
3817 case ST_DO:
3818 case ST_FORALL:
3819 case ST_WHERE:
3820 case ST_SELECT_CASE:
3821 gfc_error ("%s statement at %C cannot terminate a non-block "
3822 "DO loop", gfc_ascii_statement (st));
3823 break;
3824
3825 default:
3826 break;
3827 }
3828
3829 switch (st)
3830 {
3831 case ST_NONE:
3832 unexpected_eof ();
3833
3834 case ST_DATA:
3835 gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
3836 "first executable statement");
3837 /* Fall through. */
3838
3839 case ST_FORMAT:
3840 case ST_ENTRY:
3841 case_executable:
3842 accept_statement (st);
3843 if (close_flag == 1)
3844 return ST_IMPLIED_ENDDO;
3845 break;
3846
3847 case ST_BLOCK:
3848 parse_block_construct ();
3849 break;
3850
3851 case ST_ASSOCIATE:
3852 parse_associate ();
3853 break;
3854
3855 case ST_IF_BLOCK:
3856 parse_if_block ();
3857 break;
3858
3859 case ST_SELECT_CASE:
3860 parse_select_block ();
3861 break;
3862
3863 case ST_SELECT_TYPE:
3864 parse_select_type_block();
3865 break;
3866
3867 case ST_DO:
3868 parse_do_block ();
3869 if (check_do_closure () == 1)
3870 return ST_IMPLIED_ENDDO;
3871 break;
3872
3873 case ST_CRITICAL:
3874 parse_critical_block ();
3875 break;
3876
3877 case ST_WHERE_BLOCK:
3878 parse_where_block ();
3879 break;
3880
3881 case ST_FORALL_BLOCK:
3882 parse_forall_block ();
3883 break;
3884
3885 case ST_OMP_PARALLEL:
3886 case ST_OMP_PARALLEL_SECTIONS:
3887 case ST_OMP_SECTIONS:
3888 case ST_OMP_ORDERED:
3889 case ST_OMP_CRITICAL:
3890 case ST_OMP_MASTER:
3891 case ST_OMP_SINGLE:
3892 case ST_OMP_TASK:
3893 parse_omp_structured_block (st, false);
3894 break;
3895
3896 case ST_OMP_WORKSHARE:
3897 case ST_OMP_PARALLEL_WORKSHARE:
3898 parse_omp_structured_block (st, true);
3899 break;
3900
3901 case ST_OMP_DO:
3902 case ST_OMP_PARALLEL_DO:
3903 st = parse_omp_do (st);
3904 if (st == ST_IMPLIED_ENDDO)
3905 return st;
3906 continue;
3907
3908 case ST_OMP_ATOMIC:
3909 st = parse_omp_atomic ();
3910 continue;
3911
3912 default:
3913 return st;
3914 }
3915
3916 st = next_statement ();
3917 }
3918 }
3919
3920
3921 /* Fix the symbols for sibling functions. These are incorrectly added to
3922 the child namespace as the parser didn't know about this procedure. */
3923
3924 static void
3925 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3926 {
3927 gfc_namespace *ns;
3928 gfc_symtree *st;
3929 gfc_symbol *old_sym;
3930
3931 sym->attr.referenced = 1;
3932 for (ns = siblings; ns; ns = ns->sibling)
3933 {
3934 st = gfc_find_symtree (ns->sym_root, sym->name);
3935
3936 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3937 goto fixup_contained;
3938
3939 if ((st->n.sym->attr.flavor == FL_DERIVED
3940 && sym->attr.generic && sym->attr.function)
3941 ||(sym->attr.flavor == FL_DERIVED
3942 && st->n.sym->attr.generic && st->n.sym->attr.function))
3943 goto fixup_contained;
3944
3945 old_sym = st->n.sym;
3946 if (old_sym->ns == ns
3947 && !old_sym->attr.contained
3948
3949 /* By 14.6.1.3, host association should be excluded
3950 for the following. */
3951 && !(old_sym->attr.external
3952 || (old_sym->ts.type != BT_UNKNOWN
3953 && !old_sym->attr.implicit_type)
3954 || old_sym->attr.flavor == FL_PARAMETER
3955 || old_sym->attr.use_assoc
3956 || old_sym->attr.in_common
3957 || old_sym->attr.in_equivalence
3958 || old_sym->attr.data
3959 || old_sym->attr.dummy
3960 || old_sym->attr.result
3961 || old_sym->attr.dimension
3962 || old_sym->attr.allocatable
3963 || old_sym->attr.intrinsic
3964 || old_sym->attr.generic
3965 || old_sym->attr.flavor == FL_NAMELIST
3966 || old_sym->attr.flavor == FL_LABEL
3967 || old_sym->attr.proc == PROC_ST_FUNCTION))
3968 {
3969 /* Replace it with the symbol from the parent namespace. */
3970 st->n.sym = sym;
3971 sym->refs++;
3972
3973 gfc_release_symbol (old_sym);
3974 }
3975
3976 fixup_contained:
3977 /* Do the same for any contained procedures. */
3978 gfc_fixup_sibling_symbols (sym, ns->contained);
3979 }
3980 }
3981
3982 static void
3983 parse_contained (int module)
3984 {
3985 gfc_namespace *ns, *parent_ns, *tmp;
3986 gfc_state_data s1, s2;
3987 gfc_statement st;
3988 gfc_symbol *sym;
3989 gfc_entry_list *el;
3990 int contains_statements = 0;
3991 int seen_error = 0;
3992
3993 push_state (&s1, COMP_CONTAINS, NULL);
3994 parent_ns = gfc_current_ns;
3995
3996 do
3997 {
3998 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3999
4000 gfc_current_ns->sibling = parent_ns->contained;
4001 parent_ns->contained = gfc_current_ns;
4002
4003 next:
4004 /* Process the next available statement. We come here if we got an error
4005 and rejected the last statement. */
4006 st = next_statement ();
4007
4008 switch (st)
4009 {
4010 case ST_NONE:
4011 unexpected_eof ();
4012
4013 case ST_FUNCTION:
4014 case ST_SUBROUTINE:
4015 contains_statements = 1;
4016 accept_statement (st);
4017
4018 push_state (&s2,
4019 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
4020 gfc_new_block);
4021
4022 /* For internal procedures, create/update the symbol in the
4023 parent namespace. */
4024
4025 if (!module)
4026 {
4027 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
4028 gfc_error ("Contained procedure '%s' at %C is already "
4029 "ambiguous", gfc_new_block->name);
4030 else
4031 {
4032 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
4033 &gfc_new_block->declared_at) ==
4034 SUCCESS)
4035 {
4036 if (st == ST_FUNCTION)
4037 gfc_add_function (&sym->attr, sym->name,
4038 &gfc_new_block->declared_at);
4039 else
4040 gfc_add_subroutine (&sym->attr, sym->name,
4041 &gfc_new_block->declared_at);
4042 }
4043 }
4044
4045 gfc_commit_symbols ();
4046 }
4047 else
4048 sym = gfc_new_block;
4049
4050 /* Mark this as a contained function, so it isn't replaced
4051 by other module functions. */
4052 sym->attr.contained = 1;
4053 sym->attr.referenced = 1;
4054
4055 /* Set implicit_pure so that it can be reset if any of the
4056 tests for purity fail. This is used for some optimisation
4057 during translation. */
4058 if (!sym->attr.pure)
4059 sym->attr.implicit_pure = 1;
4060
4061 parse_progunit (ST_NONE);
4062
4063 /* Fix up any sibling functions that refer to this one. */
4064 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
4065 /* Or refer to any of its alternate entry points. */
4066 for (el = gfc_current_ns->entries; el; el = el->next)
4067 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
4068
4069 gfc_current_ns->code = s2.head;
4070 gfc_current_ns = parent_ns;
4071
4072 pop_state ();
4073 break;
4074
4075 /* These statements are associated with the end of the host unit. */
4076 case ST_END_FUNCTION:
4077 case ST_END_MODULE:
4078 case ST_END_PROGRAM:
4079 case ST_END_SUBROUTINE:
4080 accept_statement (st);
4081 gfc_current_ns->code = s1.head;
4082 break;
4083
4084 default:
4085 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4086 gfc_ascii_statement (st));
4087 reject_statement ();
4088 seen_error = 1;
4089 goto next;
4090 break;
4091 }
4092 }
4093 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
4094 && st != ST_END_MODULE && st != ST_END_PROGRAM);
4095
4096 /* The first namespace in the list is guaranteed to not have
4097 anything (worthwhile) in it. */
4098 tmp = gfc_current_ns;
4099 gfc_current_ns = parent_ns;
4100 if (seen_error && tmp->refs > 1)
4101 gfc_free_namespace (tmp);
4102
4103 ns = gfc_current_ns->contained;
4104 gfc_current_ns->contained = ns->sibling;
4105 gfc_free_namespace (ns);
4106
4107 pop_state ();
4108 if (!contains_statements)
4109 gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
4110 "FUNCTION or SUBROUTINE statement at %C");
4111 }
4112
4113
4114 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4115
4116 static void
4117 parse_progunit (gfc_statement st)
4118 {
4119 gfc_state_data *p;
4120 int n;
4121
4122 st = parse_spec (st);
4123 switch (st)
4124 {
4125 case ST_NONE:
4126 unexpected_eof ();
4127
4128 case ST_CONTAINS:
4129 /* This is not allowed within BLOCK! */
4130 if (gfc_current_state () != COMP_BLOCK)
4131 goto contains;
4132 break;
4133
4134 case_end:
4135 accept_statement (st);
4136 goto done;
4137
4138 default:
4139 break;
4140 }
4141
4142 if (gfc_current_state () == COMP_FUNCTION)
4143 gfc_check_function_type (gfc_current_ns);
4144
4145 loop:
4146 for (;;)
4147 {
4148 st = parse_executable (st);
4149
4150 switch (st)
4151 {
4152 case ST_NONE:
4153 unexpected_eof ();
4154
4155 case ST_CONTAINS:
4156 /* This is not allowed within BLOCK! */
4157 if (gfc_current_state () != COMP_BLOCK)
4158 goto contains;
4159 break;
4160
4161 case_end:
4162 accept_statement (st);
4163 goto done;
4164
4165 default:
4166 break;
4167 }
4168
4169 unexpected_statement (st);
4170 reject_statement ();
4171 st = next_statement ();
4172 }
4173
4174 contains:
4175 n = 0;
4176
4177 for (p = gfc_state_stack; p; p = p->previous)
4178 if (p->state == COMP_CONTAINS)
4179 n++;
4180
4181 if (gfc_find_state (COMP_MODULE) == SUCCESS)
4182 n--;
4183
4184 if (n > 0)
4185 {
4186 gfc_error ("CONTAINS statement at %C is already in a contained "
4187 "program unit");
4188 reject_statement ();
4189 st = next_statement ();
4190 goto loop;
4191 }
4192
4193 parse_contained (0);
4194
4195 done:
4196 gfc_current_ns->code = gfc_state_stack->head;
4197 }
4198
4199
4200 /* Come here to complain about a global symbol already in use as
4201 something else. */
4202
4203 void
4204 gfc_global_used (gfc_gsymbol *sym, locus *where)
4205 {
4206 const char *name;
4207
4208 if (where == NULL)
4209 where = &gfc_current_locus;
4210
4211 switch(sym->type)
4212 {
4213 case GSYM_PROGRAM:
4214 name = "PROGRAM";
4215 break;
4216 case GSYM_FUNCTION:
4217 name = "FUNCTION";
4218 break;
4219 case GSYM_SUBROUTINE:
4220 name = "SUBROUTINE";
4221 break;
4222 case GSYM_COMMON:
4223 name = "COMMON";
4224 break;
4225 case GSYM_BLOCK_DATA:
4226 name = "BLOCK DATA";
4227 break;
4228 case GSYM_MODULE:
4229 name = "MODULE";
4230 break;
4231 default:
4232 gfc_internal_error ("gfc_global_used(): Bad type");
4233 name = NULL;
4234 }
4235
4236 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
4237 sym->name, where, name, &sym->where);
4238 }
4239
4240
4241 /* Parse a block data program unit. */
4242
4243 static void
4244 parse_block_data (void)
4245 {
4246 gfc_statement st;
4247 static locus blank_locus;
4248 static int blank_block=0;
4249 gfc_gsymbol *s;
4250
4251 gfc_current_ns->proc_name = gfc_new_block;
4252 gfc_current_ns->is_block_data = 1;
4253
4254 if (gfc_new_block == NULL)
4255 {
4256 if (blank_block)
4257 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4258 "prior BLOCK DATA at %L", &blank_locus);
4259 else
4260 {
4261 blank_block = 1;
4262 blank_locus = gfc_current_locus;
4263 }
4264 }
4265 else
4266 {
4267 s = gfc_get_gsymbol (gfc_new_block->name);
4268 if (s->defined
4269 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4270 gfc_global_used(s, NULL);
4271 else
4272 {
4273 s->type = GSYM_BLOCK_DATA;
4274 s->where = gfc_current_locus;
4275 s->defined = 1;
4276 }
4277 }
4278
4279 st = parse_spec (ST_NONE);
4280
4281 while (st != ST_END_BLOCK_DATA)
4282 {
4283 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4284 gfc_ascii_statement (st));
4285 reject_statement ();
4286 st = next_statement ();
4287 }
4288 }
4289
4290
4291 /* Parse a module subprogram. */
4292
4293 static void
4294 parse_module (void)
4295 {
4296 gfc_statement st;
4297 gfc_gsymbol *s;
4298
4299 s = gfc_get_gsymbol (gfc_new_block->name);
4300 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4301 gfc_global_used(s, NULL);
4302 else
4303 {
4304 s->type = GSYM_MODULE;
4305 s->where = gfc_current_locus;
4306 s->defined = 1;
4307 }
4308
4309 st = parse_spec (ST_NONE);
4310
4311 loop:
4312 switch (st)
4313 {
4314 case ST_NONE:
4315 unexpected_eof ();
4316
4317 case ST_CONTAINS:
4318 parse_contained (1);
4319 break;
4320
4321 case ST_END_MODULE:
4322 accept_statement (st);
4323 break;
4324
4325 default:
4326 gfc_error ("Unexpected %s statement in MODULE at %C",
4327 gfc_ascii_statement (st));
4328
4329 reject_statement ();
4330 st = next_statement ();
4331 goto loop;
4332 }
4333
4334 s->ns = gfc_current_ns;
4335 }
4336
4337
4338 /* Add a procedure name to the global symbol table. */
4339
4340 static void
4341 add_global_procedure (int sub)
4342 {
4343 gfc_gsymbol *s;
4344
4345 s = gfc_get_gsymbol(gfc_new_block->name);
4346
4347 if (s->defined
4348 || (s->type != GSYM_UNKNOWN
4349 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4350 gfc_global_used(s, NULL);
4351 else
4352 {
4353 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4354 s->where = gfc_current_locus;
4355 s->defined = 1;
4356 s->ns = gfc_current_ns;
4357 }
4358 }
4359
4360
4361 /* Add a program to the global symbol table. */
4362
4363 static void
4364 add_global_program (void)
4365 {
4366 gfc_gsymbol *s;
4367
4368 if (gfc_new_block == NULL)
4369 return;
4370 s = gfc_get_gsymbol (gfc_new_block->name);
4371
4372 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4373 gfc_global_used(s, NULL);
4374 else
4375 {
4376 s->type = GSYM_PROGRAM;
4377 s->where = gfc_current_locus;
4378 s->defined = 1;
4379 s->ns = gfc_current_ns;
4380 }
4381 }
4382
4383
4384 /* Resolve all the program units when whole file scope option
4385 is active. */
4386 static void
4387 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4388 {
4389 gfc_free_dt_list ();
4390 gfc_current_ns = gfc_global_ns_list;
4391 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4392 {
4393 if (gfc_current_ns->proc_name
4394 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4395 continue; /* Already resolved. */
4396
4397 if (gfc_current_ns->proc_name)
4398 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4399 gfc_resolve (gfc_current_ns);
4400 gfc_current_ns->derived_types = gfc_derived_types;
4401 gfc_derived_types = NULL;
4402 }
4403 }
4404
4405
4406 static void
4407 clean_up_modules (gfc_gsymbol *gsym)
4408 {
4409 if (gsym == NULL)
4410 return;
4411
4412 clean_up_modules (gsym->left);
4413 clean_up_modules (gsym->right);
4414
4415 if (gsym->type != GSYM_MODULE || !gsym->ns)
4416 return;
4417
4418 gfc_current_ns = gsym->ns;
4419 gfc_derived_types = gfc_current_ns->derived_types;
4420 gfc_done_2 ();
4421 gsym->ns = NULL;
4422 return;
4423 }
4424
4425
4426 /* Translate all the program units when whole file scope option
4427 is active. This could be in a different order to resolution if
4428 there are forward references in the file. */
4429 static void
4430 translate_all_program_units (gfc_namespace *gfc_global_ns_list,
4431 bool main_in_tu)
4432 {
4433 int errors;
4434
4435 gfc_current_ns = gfc_global_ns_list;
4436 gfc_get_errors (NULL, &errors);
4437
4438 /* If the main program is in the translation unit and we have
4439 -fcoarray=libs, generate the static variables. */
4440 if (gfc_option.coarray == GFC_FCOARRAY_LIB && main_in_tu)
4441 gfc_init_coarray_decl (true);
4442
4443 /* We first translate all modules to make sure that later parts
4444 of the program can use the decl. Then we translate the nonmodules. */
4445
4446 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4447 {
4448 if (!gfc_current_ns->proc_name
4449 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4450 continue;
4451
4452 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4453 gfc_derived_types = gfc_current_ns->derived_types;
4454 gfc_generate_module_code (gfc_current_ns);
4455 gfc_current_ns->translated = 1;
4456 }
4457
4458 gfc_current_ns = gfc_global_ns_list;
4459 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4460 {
4461 if (gfc_current_ns->proc_name
4462 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4463 continue;
4464
4465 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4466 gfc_derived_types = gfc_current_ns->derived_types;
4467 gfc_generate_code (gfc_current_ns);
4468 gfc_current_ns->translated = 1;
4469 }
4470
4471 /* Clean up all the namespaces after translation. */
4472 gfc_current_ns = gfc_global_ns_list;
4473 for (;gfc_current_ns;)
4474 {
4475 gfc_namespace *ns;
4476
4477 if (gfc_current_ns->proc_name
4478 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4479 {
4480 gfc_current_ns = gfc_current_ns->sibling;
4481 continue;
4482 }
4483
4484 ns = gfc_current_ns->sibling;
4485 gfc_derived_types = gfc_current_ns->derived_types;
4486 gfc_done_2 ();
4487 gfc_current_ns = ns;
4488 }
4489
4490 clean_up_modules (gfc_gsym_root);
4491 }
4492
4493
4494 /* Top level parser. */
4495
4496 gfc_try
4497 gfc_parse_file (void)
4498 {
4499 int seen_program, errors_before, errors;
4500 gfc_state_data top, s;
4501 gfc_statement st;
4502 locus prog_locus;
4503 gfc_namespace *next;
4504
4505 gfc_start_source_files ();
4506
4507 top.state = COMP_NONE;
4508 top.sym = NULL;
4509 top.previous = NULL;
4510 top.head = top.tail = NULL;
4511 top.do_variable = NULL;
4512
4513 gfc_state_stack = &top;
4514
4515 gfc_clear_new_st ();
4516
4517 gfc_statement_label = NULL;
4518
4519 if (setjmp (eof_buf))
4520 return FAILURE; /* Come here on unexpected EOF */
4521
4522 /* Prepare the global namespace that will contain the
4523 program units. */
4524 gfc_global_ns_list = next = NULL;
4525
4526 seen_program = 0;
4527 errors_before = 0;
4528
4529 /* Exit early for empty files. */
4530 if (gfc_at_eof ())
4531 goto done;
4532
4533 loop:
4534 gfc_init_2 ();
4535 st = next_statement ();
4536 switch (st)
4537 {
4538 case ST_NONE:
4539 gfc_done_2 ();
4540 goto done;
4541
4542 case ST_PROGRAM:
4543 if (seen_program)
4544 goto duplicate_main;
4545 seen_program = 1;
4546 prog_locus = gfc_current_locus;
4547
4548 push_state (&s, COMP_PROGRAM, gfc_new_block);
4549 main_program_symbol(gfc_current_ns, gfc_new_block->name);
4550 accept_statement (st);
4551 add_global_program ();
4552 parse_progunit (ST_NONE);
4553 if (gfc_option.flag_whole_file)
4554 goto prog_units;
4555 break;
4556
4557 case ST_SUBROUTINE:
4558 add_global_procedure (1);
4559 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4560 accept_statement (st);
4561 parse_progunit (ST_NONE);
4562 if (gfc_option.flag_whole_file)
4563 goto prog_units;
4564 break;
4565
4566 case ST_FUNCTION:
4567 add_global_procedure (0);
4568 push_state (&s, COMP_FUNCTION, gfc_new_block);
4569 accept_statement (st);
4570 parse_progunit (ST_NONE);
4571 if (gfc_option.flag_whole_file)
4572 goto prog_units;
4573 break;
4574
4575 case ST_BLOCK_DATA:
4576 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4577 accept_statement (st);
4578 parse_block_data ();
4579 break;
4580
4581 case ST_MODULE:
4582 push_state (&s, COMP_MODULE, gfc_new_block);
4583 accept_statement (st);
4584
4585 gfc_get_errors (NULL, &errors_before);
4586 parse_module ();
4587 break;
4588
4589 /* Anything else starts a nameless main program block. */
4590 default:
4591 if (seen_program)
4592 goto duplicate_main;
4593 seen_program = 1;
4594 prog_locus = gfc_current_locus;
4595
4596 push_state (&s, COMP_PROGRAM, gfc_new_block);
4597 main_program_symbol (gfc_current_ns, "MAIN__");
4598 parse_progunit (st);
4599 if (gfc_option.flag_whole_file)
4600 goto prog_units;
4601 break;
4602 }
4603
4604 /* Handle the non-program units. */
4605 gfc_current_ns->code = s.head;
4606
4607 gfc_resolve (gfc_current_ns);
4608
4609 /* Dump the parse tree if requested. */
4610 if (gfc_option.dump_fortran_original)
4611 gfc_dump_parse_tree (gfc_current_ns, stdout);
4612
4613 gfc_get_errors (NULL, &errors);
4614 if (s.state == COMP_MODULE)
4615 {
4616 gfc_dump_module (s.sym->name, errors_before == errors);
4617 if (!gfc_option.flag_whole_file)
4618 {
4619 if (errors == 0)
4620 gfc_generate_module_code (gfc_current_ns);
4621 pop_state ();
4622 gfc_done_2 ();
4623 }
4624 else
4625 {
4626 gfc_current_ns->derived_types = gfc_derived_types;
4627 gfc_derived_types = NULL;
4628 goto prog_units;
4629 }
4630 }
4631 else
4632 {
4633 if (errors == 0)
4634 gfc_generate_code (gfc_current_ns);
4635 pop_state ();
4636 gfc_done_2 ();
4637 }
4638
4639 goto loop;
4640
4641 prog_units:
4642 /* The main program and non-contained procedures are put
4643 in the global namespace list, so that they can be processed
4644 later and all their interfaces resolved. */
4645 gfc_current_ns->code = s.head;
4646 if (next)
4647 {
4648 for (; next->sibling; next = next->sibling)
4649 ;
4650 next->sibling = gfc_current_ns;
4651 }
4652 else
4653 gfc_global_ns_list = gfc_current_ns;
4654
4655 next = gfc_current_ns;
4656
4657 pop_state ();
4658 goto loop;
4659
4660 done:
4661
4662 if (!gfc_option.flag_whole_file)
4663 goto termination;
4664
4665 /* Do the resolution. */
4666 resolve_all_program_units (gfc_global_ns_list);
4667
4668 /* Do the parse tree dump. */
4669 gfc_current_ns
4670 = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
4671
4672 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4673 if (!gfc_current_ns->proc_name
4674 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4675 {
4676 gfc_dump_parse_tree (gfc_current_ns, stdout);
4677 fputs ("------------------------------------------\n\n", stdout);
4678 }
4679
4680 /* Do the translation. */
4681 translate_all_program_units (gfc_global_ns_list, seen_program);
4682
4683 termination:
4684
4685 gfc_end_source_files ();
4686 return SUCCESS;
4687
4688 duplicate_main:
4689 /* If we see a duplicate main program, shut down. If the second
4690 instance is an implied main program, i.e. data decls or executable
4691 statements, we're in for lots of errors. */
4692 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4693 reject_statement ();
4694 gfc_done_2 ();
4695 return SUCCESS;
4696 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org