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