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