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