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