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