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