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