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