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