?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merged r158465 through r158660 into branch.
[official-gcc.git] / gcc / fortran / parse.c
blobef8931d2a2ce94f3cf5111eeff7e4c9a058c9f0c
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
2086 && c->ts.u.derived->components->attr.allocatable)
2087 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2088 sym->attr.alloc_comp = 1;
2089
2090 /* Look for pointer components. */
2091 if (c->attr.pointer
2092 || (c->ts.type == BT_CLASS
2093 && c->ts.u.derived->components->attr.pointer)
2094 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2095 sym->attr.pointer_comp = 1;
2096
2097 /* Look for procedure pointer components. */
2098 if (c->attr.proc_pointer
2099 || (c->ts.type == BT_DERIVED
2100 && c->ts.u.derived->attr.proc_pointer_comp))
2101 sym->attr.proc_pointer_comp = 1;
2102
2103 /* Looking for coarray components. */
2104 if (c->attr.codimension
2105 || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
2106 sym->attr.coarray_comp = 1;
2107
2108 /* Look for private components. */
2109 if (sym->component_access == ACCESS_PRIVATE
2110 || c->attr.access == ACCESS_PRIVATE
2111 || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2112 sym->attr.private_comp = 1;
2113 }
2114
2115 if (!seen_component)
2116 sym->attr.zero_comp = 1;
2117
2118 pop_state ();
2119 }
2120
2121
2122 /* Parse an ENUM. */
2123
2124 static void
2125 parse_enum (void)
2126 {
2127 gfc_statement st;
2128 int compiling_enum;
2129 gfc_state_data s;
2130 int seen_enumerator = 0;
2131
2132 push_state (&s, COMP_ENUM, gfc_new_block);
2133
2134 compiling_enum = 1;
2135
2136 while (compiling_enum)
2137 {
2138 st = next_statement ();
2139 switch (st)
2140 {
2141 case ST_NONE:
2142 unexpected_eof ();
2143 break;
2144
2145 case ST_ENUMERATOR:
2146 seen_enumerator = 1;
2147 accept_statement (st);
2148 break;
2149
2150 case ST_END_ENUM:
2151 compiling_enum = 0;
2152 if (!seen_enumerator)
2153 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2154 accept_statement (st);
2155 break;
2156
2157 default:
2158 gfc_free_enum_history ();
2159 unexpected_statement (st);
2160 break;
2161 }
2162 }
2163 pop_state ();
2164 }
2165
2166
2167 /* Parse an interface. We must be able to deal with the possibility
2168 of recursive interfaces. The parse_spec() subroutine is mutually
2169 recursive with parse_interface(). */
2170
2171 static gfc_statement parse_spec (gfc_statement);
2172
2173 static void
2174 parse_interface (void)
2175 {
2176 gfc_compile_state new_state = COMP_NONE, current_state;
2177 gfc_symbol *prog_unit, *sym;
2178 gfc_interface_info save;
2179 gfc_state_data s1, s2;
2180 gfc_statement st;
2181 locus proc_locus;
2182
2183 accept_statement (ST_INTERFACE);
2184
2185 current_interface.ns = gfc_current_ns;
2186 save = current_interface;
2187
2188 sym = (current_interface.type == INTERFACE_GENERIC
2189 || current_interface.type == INTERFACE_USER_OP)
2190 ? gfc_new_block : NULL;
2191
2192 push_state (&s1, COMP_INTERFACE, sym);
2193 current_state = COMP_NONE;
2194
2195 loop:
2196 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2197
2198 st = next_statement ();
2199 switch (st)
2200 {
2201 case ST_NONE:
2202 unexpected_eof ();
2203
2204 case ST_SUBROUTINE:
2205 case ST_FUNCTION:
2206 if (st == ST_SUBROUTINE)
2207 new_state = COMP_SUBROUTINE;
2208 else if (st == ST_FUNCTION)
2209 new_state = COMP_FUNCTION;
2210 if (gfc_new_block->attr.pointer)
2211 {
2212 gfc_new_block->attr.pointer = 0;
2213 gfc_new_block->attr.proc_pointer = 1;
2214 }
2215 if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2216 gfc_new_block->formal, NULL) == FAILURE)
2217 {
2218 reject_statement ();
2219 gfc_free_namespace (gfc_current_ns);
2220 goto loop;
2221 }
2222 break;
2223
2224 case ST_PROCEDURE:
2225 case ST_MODULE_PROC: /* The module procedure matcher makes
2226 sure the context is correct. */
2227 accept_statement (st);
2228 gfc_free_namespace (gfc_current_ns);
2229 goto loop;
2230
2231 case ST_END_INTERFACE:
2232 gfc_free_namespace (gfc_current_ns);
2233 gfc_current_ns = current_interface.ns;
2234 goto done;
2235
2236 default:
2237 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2238 gfc_ascii_statement (st));
2239 reject_statement ();
2240 gfc_free_namespace (gfc_current_ns);
2241 goto loop;
2242 }
2243
2244
2245 /* Make sure that a generic interface has only subroutines or
2246 functions and that the generic name has the right attribute. */
2247 if (current_interface.type == INTERFACE_GENERIC)
2248 {
2249 if (current_state == COMP_NONE)
2250 {
2251 if (new_state == COMP_FUNCTION)
2252 gfc_add_function (&sym->attr, sym->name, NULL);
2253 else if (new_state == COMP_SUBROUTINE)
2254 gfc_add_subroutine (&sym->attr, sym->name, NULL);
2255
2256 current_state = new_state;
2257 }
2258 else
2259 {
2260 if (new_state != current_state)
2261 {
2262 if (new_state == COMP_SUBROUTINE)
2263 gfc_error ("SUBROUTINE at %C does not belong in a "
2264 "generic function interface");
2265
2266 if (new_state == COMP_FUNCTION)
2267 gfc_error ("FUNCTION at %C does not belong in a "
2268 "generic subroutine interface");
2269 }
2270 }
2271 }
2272
2273 if (current_interface.type == INTERFACE_ABSTRACT)
2274 {
2275 gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2276 if (gfc_is_intrinsic_typename (gfc_new_block->name))
2277 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2278 "cannot be the same as an intrinsic type",
2279 gfc_new_block->name);
2280 }
2281
2282 push_state (&s2, new_state, gfc_new_block);
2283 accept_statement (st);
2284 prog_unit = gfc_new_block;
2285 prog_unit->formal_ns = gfc_current_ns;
2286 proc_locus = gfc_current_locus;
2287
2288 decl:
2289 /* Read data declaration statements. */
2290 st = parse_spec (ST_NONE);
2291
2292 /* Since the interface block does not permit an IMPLICIT statement,
2293 the default type for the function or the result must be taken
2294 from the formal namespace. */
2295 if (new_state == COMP_FUNCTION)
2296 {
2297 if (prog_unit->result == prog_unit
2298 && prog_unit->ts.type == BT_UNKNOWN)
2299 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2300 else if (prog_unit->result != prog_unit
2301 && prog_unit->result->ts.type == BT_UNKNOWN)
2302 gfc_set_default_type (prog_unit->result, 1,
2303 prog_unit->formal_ns);
2304 }
2305
2306 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2307 {
2308 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2309 gfc_ascii_statement (st));
2310 reject_statement ();
2311 goto decl;
2312 }
2313
2314 /* Add EXTERNAL attribute to function or subroutine. */
2315 if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2316 gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2317
2318 current_interface = save;
2319 gfc_add_interface (prog_unit);
2320 pop_state ();
2321
2322 if (current_interface.ns
2323 && current_interface.ns->proc_name
2324 && strcmp (current_interface.ns->proc_name->name,
2325 prog_unit->name) == 0)
2326 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2327 "enclosing procedure", prog_unit->name, &proc_locus);
2328
2329 goto loop;
2330
2331 done:
2332 pop_state ();
2333 }
2334
2335
2336 /* Associate function characteristics by going back to the function
2337 declaration and rematching the prefix. */
2338
2339 static match
2340 match_deferred_characteristics (gfc_typespec * ts)
2341 {
2342 locus loc;
2343 match m = MATCH_ERROR;
2344 char name[GFC_MAX_SYMBOL_LEN + 1];
2345
2346 loc = gfc_current_locus;
2347
2348 gfc_current_locus = gfc_current_block ()->declared_at;
2349
2350 gfc_clear_error ();
2351 gfc_buffer_error (1);
2352 m = gfc_match_prefix (ts);
2353 gfc_buffer_error (0);
2354
2355 if (ts->type == BT_DERIVED)
2356 {
2357 ts->kind = 0;
2358
2359 if (!ts->u.derived)
2360 m = MATCH_ERROR;
2361 }
2362
2363 /* Only permit one go at the characteristic association. */
2364 if (ts->kind == -1)
2365 ts->kind = 0;
2366
2367 /* Set the function locus correctly. If we have not found the
2368 function name, there is an error. */
2369 if (m == MATCH_YES
2370 && gfc_match ("function% %n", name) == MATCH_YES
2371 && strcmp (name, gfc_current_block ()->name) == 0)
2372 {
2373 gfc_current_block ()->declared_at = gfc_current_locus;
2374 gfc_commit_symbols ();
2375 }
2376 else
2377 gfc_error_check ();
2378
2379 gfc_current_locus =loc;
2380 return m;
2381 }
2382
2383
2384 /* Check specification-expressions in the function result of the currently
2385 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2386 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2387 scope are not yet parsed so this has to be delayed up to parse_spec. */
2388
2389 static void
2390 check_function_result_typed (void)
2391 {
2392 gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2393
2394 gcc_assert (gfc_current_state () == COMP_FUNCTION);
2395 gcc_assert (ts->type != BT_UNKNOWN);
2396
2397 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2398 /* TODO: Extend when KIND type parameters are implemented. */
2399 if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2400 gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2401 }
2402
2403
2404 /* Parse a set of specification statements. Returns the statement
2405 that doesn't fit. */
2406
2407 static gfc_statement
2408 parse_spec (gfc_statement st)
2409 {
2410 st_state ss;
2411 bool function_result_typed = false;
2412 bool bad_characteristic = false;
2413 gfc_typespec *ts;
2414
2415 verify_st_order (&ss, ST_NONE, false);
2416 if (st == ST_NONE)
2417 st = next_statement ();
2418
2419 /* If we are not inside a function or don't have a result specified so far,
2420 do nothing special about it. */
2421 if (gfc_current_state () != COMP_FUNCTION)
2422 function_result_typed = true;
2423 else
2424 {
2425 gfc_symbol* proc = gfc_current_ns->proc_name;
2426 gcc_assert (proc);
2427
2428 if (proc->result->ts.type == BT_UNKNOWN)
2429 function_result_typed = true;
2430 }
2431
2432 loop:
2433
2434 /* If we're inside a BLOCK construct, some statements are disallowed.
2435 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2436 or VALUE are also disallowed, but they don't have a particular ST_*
2437 key so we have to check for them individually in their matcher routine. */
2438 if (gfc_current_state () == COMP_BLOCK)
2439 switch (st)
2440 {
2441 case ST_IMPLICIT:
2442 case ST_IMPLICIT_NONE:
2443 case ST_NAMELIST:
2444 case ST_COMMON:
2445 case ST_EQUIVALENCE:
2446 case ST_STATEMENT_FUNCTION:
2447 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2448 gfc_ascii_statement (st));
2449 break;
2450
2451 default:
2452 break;
2453 }
2454
2455 /* If we find a statement that can not be followed by an IMPLICIT statement
2456 (and thus we can expect to see none any further), type the function result
2457 if it has not yet been typed. Be careful not to give the END statement
2458 to verify_st_order! */
2459 if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2460 {
2461 bool verify_now = false;
2462
2463 if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2464 verify_now = true;
2465 else
2466 {
2467 st_state dummyss;
2468 verify_st_order (&dummyss, ST_NONE, false);
2469 verify_st_order (&dummyss, st, false);
2470
2471 if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2472 verify_now = true;
2473 }
2474
2475 if (verify_now)
2476 {
2477 check_function_result_typed ();
2478 function_result_typed = true;
2479 }
2480 }
2481
2482 switch (st)
2483 {
2484 case ST_NONE:
2485 unexpected_eof ();
2486
2487 case ST_IMPLICIT_NONE:
2488 case ST_IMPLICIT:
2489 if (!function_result_typed)
2490 {
2491 check_function_result_typed ();
2492 function_result_typed = true;
2493 }
2494 goto declSt;
2495
2496 case ST_FORMAT:
2497 case ST_ENTRY:
2498 case ST_DATA: /* Not allowed in interfaces */
2499 if (gfc_current_state () == COMP_INTERFACE)
2500 break;
2501
2502 /* Fall through */
2503
2504 case ST_USE:
2505 case ST_IMPORT:
2506 case ST_PARAMETER:
2507 case ST_PUBLIC:
2508 case ST_PRIVATE:
2509 case ST_DERIVED_DECL:
2510 case_decl:
2511 declSt:
2512 if (verify_st_order (&ss, st, false) == FAILURE)
2513 {
2514 reject_statement ();
2515 st = next_statement ();
2516 goto loop;
2517 }
2518
2519 switch (st)
2520 {
2521 case ST_INTERFACE:
2522 parse_interface ();
2523 break;
2524
2525 case ST_DERIVED_DECL:
2526 parse_derived ();
2527 break;
2528
2529 case ST_PUBLIC:
2530 case ST_PRIVATE:
2531 if (gfc_current_state () != COMP_MODULE)
2532 {
2533 gfc_error ("%s statement must appear in a MODULE",
2534 gfc_ascii_statement (st));
2535 break;
2536 }
2537
2538 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2539 {
2540 gfc_error ("%s statement at %C follows another accessibility "
2541 "specification", gfc_ascii_statement (st));
2542 break;
2543 }
2544
2545 gfc_current_ns->default_access = (st == ST_PUBLIC)
2546 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2547
2548 break;
2549
2550 case ST_STATEMENT_FUNCTION:
2551 if (gfc_current_state () == COMP_MODULE)
2552 {
2553 unexpected_statement (st);
2554 break;
2555 }
2556
2557 default:
2558 break;
2559 }
2560
2561 accept_statement (st);
2562 st = next_statement ();
2563 goto loop;
2564
2565 case ST_ENUM:
2566 accept_statement (st);
2567 parse_enum();
2568 st = next_statement ();
2569 goto loop;
2570
2571 case ST_GET_FCN_CHARACTERISTICS:
2572 /* This statement triggers the association of a function's result
2573 characteristics. */
2574 ts = &gfc_current_block ()->result->ts;
2575 if (match_deferred_characteristics (ts) != MATCH_YES)
2576 bad_characteristic = true;
2577
2578 st = next_statement ();
2579 goto loop;
2580
2581 default:
2582 break;
2583 }
2584
2585 /* If match_deferred_characteristics failed, then there is an error. */
2586 if (bad_characteristic)
2587 {
2588 ts = &gfc_current_block ()->result->ts;
2589 if (ts->type != BT_DERIVED)
2590 gfc_error ("Bad kind expression for function '%s' at %L",
2591 gfc_current_block ()->name,
2592 &gfc_current_block ()->declared_at);
2593 else
2594 gfc_error ("The type for function '%s' at %L is not accessible",
2595 gfc_current_block ()->name,
2596 &gfc_current_block ()->declared_at);
2597
2598 gfc_current_block ()->ts.kind = 0;
2599 /* Keep the derived type; if it's bad, it will be discovered later. */
2600 if (!(ts->type == BT_DERIVED && ts->u.derived))
2601 ts->type = BT_UNKNOWN;
2602 }
2603
2604 return st;
2605 }
2606
2607
2608 /* Parse a WHERE block, (not a simple WHERE statement). */
2609
2610 static void
2611 parse_where_block (void)
2612 {
2613 int seen_empty_else;
2614 gfc_code *top, *d;
2615 gfc_state_data s;
2616 gfc_statement st;
2617
2618 accept_statement (ST_WHERE_BLOCK);
2619 top = gfc_state_stack->tail;
2620
2621 push_state (&s, COMP_WHERE, gfc_new_block);
2622
2623 d = add_statement ();
2624 d->expr1 = top->expr1;
2625 d->op = EXEC_WHERE;
2626
2627 top->expr1 = NULL;
2628 top->block = d;
2629
2630 seen_empty_else = 0;
2631
2632 do
2633 {
2634 st = next_statement ();
2635 switch (st)
2636 {
2637 case ST_NONE:
2638 unexpected_eof ();
2639
2640 case ST_WHERE_BLOCK:
2641 parse_where_block ();
2642 break;
2643
2644 case ST_ASSIGNMENT:
2645 case ST_WHERE:
2646 accept_statement (st);
2647 break;
2648
2649 case ST_ELSEWHERE:
2650 if (seen_empty_else)
2651 {
2652 gfc_error ("ELSEWHERE statement at %C follows previous "
2653 "unmasked ELSEWHERE");
2654 break;
2655 }
2656
2657 if (new_st.expr1 == NULL)
2658 seen_empty_else = 1;
2659
2660 d = new_level (gfc_state_stack->head);
2661 d->op = EXEC_WHERE;
2662 d->expr1 = new_st.expr1;
2663
2664 accept_statement (st);
2665
2666 break;
2667
2668 case ST_END_WHERE:
2669 accept_statement (st);
2670 break;
2671
2672 default:
2673 gfc_error ("Unexpected %s statement in WHERE block at %C",
2674 gfc_ascii_statement (st));
2675 reject_statement ();
2676 break;
2677 }
2678 }
2679 while (st != ST_END_WHERE);
2680
2681 pop_state ();
2682 }
2683
2684
2685 /* Parse a FORALL block (not a simple FORALL statement). */
2686
2687 static void
2688 parse_forall_block (void)
2689 {
2690 gfc_code *top, *d;
2691 gfc_state_data s;
2692 gfc_statement st;
2693
2694 accept_statement (ST_FORALL_BLOCK);
2695 top = gfc_state_stack->tail;
2696
2697 push_state (&s, COMP_FORALL, gfc_new_block);
2698
2699 d = add_statement ();
2700 d->op = EXEC_FORALL;
2701 top->block = d;
2702
2703 do
2704 {
2705 st = next_statement ();
2706 switch (st)
2707 {
2708
2709 case ST_ASSIGNMENT:
2710 case ST_POINTER_ASSIGNMENT:
2711 case ST_WHERE:
2712 case ST_FORALL:
2713 accept_statement (st);
2714 break;
2715
2716 case ST_WHERE_BLOCK:
2717 parse_where_block ();
2718 break;
2719
2720 case ST_FORALL_BLOCK:
2721 parse_forall_block ();
2722 break;
2723
2724 case ST_END_FORALL:
2725 accept_statement (st);
2726 break;
2727
2728 case ST_NONE:
2729 unexpected_eof ();
2730
2731 default:
2732 gfc_error ("Unexpected %s statement in FORALL block at %C",
2733 gfc_ascii_statement (st));
2734
2735 reject_statement ();
2736 break;
2737 }
2738 }
2739 while (st != ST_END_FORALL);
2740
2741 pop_state ();
2742 }
2743
2744
2745 static gfc_statement parse_executable (gfc_statement);
2746
2747 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2748
2749 static void
2750 parse_if_block (void)
2751 {
2752 gfc_code *top, *d;
2753 gfc_statement st;
2754 locus else_locus;
2755 gfc_state_data s;
2756 int seen_else;
2757
2758 seen_else = 0;
2759 accept_statement (ST_IF_BLOCK);
2760
2761 top = gfc_state_stack->tail;
2762 push_state (&s, COMP_IF, gfc_new_block);
2763
2764 new_st.op = EXEC_IF;
2765 d = add_statement ();
2766
2767 d->expr1 = top->expr1;
2768 top->expr1 = NULL;
2769 top->block = d;
2770
2771 do
2772 {
2773 st = parse_executable (ST_NONE);
2774
2775 switch (st)
2776 {
2777 case ST_NONE:
2778 unexpected_eof ();
2779
2780 case ST_ELSEIF:
2781 if (seen_else)
2782 {
2783 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2784 "statement at %L", &else_locus);
2785
2786 reject_statement ();
2787 break;
2788 }
2789
2790 d = new_level (gfc_state_stack->head);
2791 d->op = EXEC_IF;
2792 d->expr1 = new_st.expr1;
2793
2794 accept_statement (st);
2795
2796 break;
2797
2798 case ST_ELSE:
2799 if (seen_else)
2800 {
2801 gfc_error ("Duplicate ELSE statements at %L and %C",
2802 &else_locus);
2803 reject_statement ();
2804 break;
2805 }
2806
2807 seen_else = 1;
2808 else_locus = gfc_current_locus;
2809
2810 d = new_level (gfc_state_stack->head);
2811 d->op = EXEC_IF;
2812
2813 accept_statement (st);
2814
2815 break;
2816
2817 case ST_ENDIF:
2818 break;
2819
2820 default:
2821 unexpected_statement (st);
2822 break;
2823 }
2824 }
2825 while (st != ST_ENDIF);
2826
2827 pop_state ();
2828 accept_statement (st);
2829 }
2830
2831
2832 /* Parse a SELECT block. */
2833
2834 static void
2835 parse_select_block (void)
2836 {
2837 gfc_statement st;
2838 gfc_code *cp;
2839 gfc_state_data s;
2840
2841 accept_statement (ST_SELECT_CASE);
2842
2843 cp = gfc_state_stack->tail;
2844 push_state (&s, COMP_SELECT, gfc_new_block);
2845
2846 /* Make sure that the next statement is a CASE or END SELECT. */
2847 for (;;)
2848 {
2849 st = next_statement ();
2850 if (st == ST_NONE)
2851 unexpected_eof ();
2852 if (st == ST_END_SELECT)
2853 {
2854 /* Empty SELECT CASE is OK. */
2855 accept_statement (st);
2856 pop_state ();
2857 return;
2858 }
2859 if (st == ST_CASE)
2860 break;
2861
2862 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2863 "CASE at %C");
2864
2865 reject_statement ();
2866 }
2867
2868 /* At this point, we're got a nonempty select block. */
2869 cp = new_level (cp);
2870 *cp = new_st;
2871
2872 accept_statement (st);
2873
2874 do
2875 {
2876 st = parse_executable (ST_NONE);
2877 switch (st)
2878 {
2879 case ST_NONE:
2880 unexpected_eof ();
2881
2882 case ST_CASE:
2883 cp = new_level (gfc_state_stack->head);
2884 *cp = new_st;
2885 gfc_clear_new_st ();
2886
2887 accept_statement (st);
2888 /* Fall through */
2889
2890 case ST_END_SELECT:
2891 break;
2892
2893 /* Can't have an executable statement because of
2894 parse_executable(). */
2895 default:
2896 unexpected_statement (st);
2897 break;
2898 }
2899 }
2900 while (st != ST_END_SELECT);
2901
2902 pop_state ();
2903 accept_statement (st);
2904 }
2905
2906
2907 /* Pop the current selector from the SELECT TYPE stack. */
2908
2909 static void
2910 select_type_pop (void)
2911 {
2912 gfc_select_type_stack *old = select_type_stack;
2913 select_type_stack = old->prev;
2914 gfc_free (old);
2915 }
2916
2917
2918 /* Parse a SELECT TYPE construct (F03:R821). */
2919
2920 static void
2921 parse_select_type_block (void)
2922 {
2923 gfc_statement st;
2924 gfc_code *cp;
2925 gfc_state_data s;
2926
2927 accept_statement (ST_SELECT_TYPE);
2928
2929 cp = gfc_state_stack->tail;
2930 push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
2931
2932 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2933 or END SELECT. */
2934 for (;;)
2935 {
2936 st = next_statement ();
2937 if (st == ST_NONE)
2938 unexpected_eof ();
2939 if (st == ST_END_SELECT)
2940 /* Empty SELECT CASE is OK. */
2941 goto done;
2942 if (st == ST_TYPE_IS || st == ST_CLASS_IS)
2943 break;
2944
2945 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2946 "following SELECT TYPE at %C");
2947
2948 reject_statement ();
2949 }
2950
2951 /* At this point, we're got a nonempty select block. */
2952 cp = new_level (cp);
2953 *cp = new_st;
2954
2955 accept_statement (st);
2956
2957 do
2958 {
2959 st = parse_executable (ST_NONE);
2960 switch (st)
2961 {
2962 case ST_NONE:
2963 unexpected_eof ();
2964
2965 case ST_TYPE_IS:
2966 case ST_CLASS_IS:
2967 cp = new_level (gfc_state_stack->head);
2968 *cp = new_st;
2969 gfc_clear_new_st ();
2970
2971 accept_statement (st);
2972 /* Fall through */
2973
2974 case ST_END_SELECT:
2975 break;
2976
2977 /* Can't have an executable statement because of
2978 parse_executable(). */
2979 default:
2980 unexpected_statement (st);
2981 break;
2982 }
2983 }
2984 while (st != ST_END_SELECT);
2985
2986 done:
2987 pop_state ();
2988 accept_statement (st);
2989 gfc_current_ns = gfc_current_ns->parent;
2990 select_type_pop ();
2991 }
2992
2993
2994 /* Given a symbol, make sure it is not an iteration variable for a DO
2995 statement. This subroutine is called when the symbol is seen in a
2996 context that causes it to become redefined. If the symbol is an
2997 iterator, we generate an error message and return nonzero. */
2998
2999 int
3000 gfc_check_do_variable (gfc_symtree *st)
3001 {
3002 gfc_state_data *s;
3003
3004 for (s=gfc_state_stack; s; s = s->previous)
3005 if (s->do_variable == st)
3006 {
3007 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3008 "loop beginning at %L", st->name, &s->head->loc);
3009 return 1;
3010 }
3011
3012 return 0;
3013 }
3014
3015
3016 /* Checks to see if the current statement label closes an enddo.
3017 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3018 an error) if it incorrectly closes an ENDDO. */
3019
3020 static int
3021 check_do_closure (void)
3022 {
3023 gfc_state_data *p;
3024
3025 if (gfc_statement_label == NULL)
3026 return 0;
3027
3028 for (p = gfc_state_stack; p; p = p->previous)
3029 if (p->state == COMP_DO)
3030 break;
3031
3032 if (p == NULL)
3033 return 0; /* No loops to close */
3034
3035 if (p->ext.end_do_label == gfc_statement_label)
3036 {
3037 if (p == gfc_state_stack)
3038 return 1;
3039
3040 gfc_error ("End of nonblock DO statement at %C is within another block");
3041 return 2;
3042 }
3043
3044 /* At this point, the label doesn't terminate the innermost loop.
3045 Make sure it doesn't terminate another one. */
3046 for (; p; p = p->previous)
3047 if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
3048 {
3049 gfc_error ("End of nonblock DO statement at %C is interwoven "
3050 "with another DO loop");
3051 return 2;
3052 }
3053
3054 return 0;
3055 }
3056
3057
3058 /* Parse a series of contained program units. */
3059
3060 static void parse_progunit (gfc_statement);
3061
3062
3063 /* Parse a CRITICAL block. */
3064
3065 static void
3066 parse_critical_block (void)
3067 {
3068 gfc_code *top, *d;
3069 gfc_state_data s;
3070 gfc_statement st;
3071
3072 s.ext.end_do_label = new_st.label1;
3073
3074 accept_statement (ST_CRITICAL);
3075 top = gfc_state_stack->tail;
3076
3077 push_state (&s, COMP_CRITICAL, gfc_new_block);
3078
3079 d = add_statement ();
3080 d->op = EXEC_CRITICAL;
3081 top->block = d;
3082
3083 do
3084 {
3085 st = parse_executable (ST_NONE);
3086
3087 switch (st)
3088 {
3089 case ST_NONE:
3090 unexpected_eof ();
3091 break;
3092
3093 case ST_END_CRITICAL:
3094 if (s.ext.end_do_label != NULL
3095 && s.ext.end_do_label != gfc_statement_label)
3096 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3097 "match CRITIAL label");
3098
3099 if (gfc_statement_label != NULL)
3100 {
3101 new_st.op = EXEC_NOP;
3102 add_statement ();
3103 }
3104 break;
3105
3106 default:
3107 unexpected_statement (st);
3108 break;
3109 }
3110 }
3111 while (st != ST_END_CRITICAL);
3112
3113 pop_state ();
3114 accept_statement (st);
3115 }
3116
3117
3118 /* Set up the local namespace for a BLOCK construct. */
3119
3120 gfc_namespace*
3121 gfc_build_block_ns (gfc_namespace *parent_ns)
3122 {
3123 gfc_namespace* my_ns;
3124
3125 my_ns = gfc_get_namespace (parent_ns, 1);
3126 my_ns->construct_entities = 1;
3127
3128 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3129 code generation (so it must not be NULL).
3130 We set its recursive argument if our container procedure is recursive, so
3131 that local variables are accordingly placed on the stack when it
3132 will be necessary. */
3133 if (gfc_new_block)
3134 my_ns->proc_name = gfc_new_block;
3135 else
3136 {
3137 gfc_try t;
3138
3139 gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
3140 t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3141 my_ns->proc_name->name, NULL);
3142 gcc_assert (t == SUCCESS);
3143 }
3144
3145 if (parent_ns->proc_name)
3146 my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3147
3148 return my_ns;
3149 }
3150
3151
3152 /* Parse a BLOCK construct. */
3153
3154 static void
3155 parse_block_construct (void)
3156 {
3157 gfc_namespace* my_ns;
3158 gfc_state_data s;
3159
3160 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3161
3162 my_ns = gfc_build_block_ns (gfc_current_ns);
3163
3164 new_st.op = EXEC_BLOCK;
3165 new_st.ext.ns = my_ns;
3166 accept_statement (ST_BLOCK);
3167
3168 push_state (&s, COMP_BLOCK, my_ns->proc_name);
3169 gfc_current_ns = my_ns;
3170
3171 parse_progunit (ST_NONE);
3172
3173 gfc_current_ns = gfc_current_ns->parent;
3174 pop_state ();
3175 }
3176
3177
3178 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3179 handled inside of parse_executable(), because they aren't really
3180 loop statements. */
3181
3182 static void
3183 parse_do_block (void)
3184 {
3185 gfc_statement st;
3186 gfc_code *top;
3187 gfc_state_data s;
3188 gfc_symtree *stree;
3189
3190 s.ext.end_do_label = new_st.label1;
3191
3192 if (new_st.ext.iterator != NULL)
3193 stree = new_st.ext.iterator->var->symtree;
3194 else
3195 stree = NULL;
3196
3197 accept_statement (ST_DO);
3198
3199 top = gfc_state_stack->tail;
3200 push_state (&s, COMP_DO, gfc_new_block);
3201
3202 s.do_variable = stree;
3203
3204 top->block = new_level (top);
3205 top->block->op = EXEC_DO;
3206
3207 loop:
3208 st = parse_executable (ST_NONE);
3209
3210 switch (st)
3211 {
3212 case ST_NONE:
3213 unexpected_eof ();
3214
3215 case ST_ENDDO:
3216 if (s.ext.end_do_label != NULL
3217 && s.ext.end_do_label != gfc_statement_label)
3218 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3219 "DO label");
3220
3221 if (gfc_statement_label != NULL)
3222 {
3223 new_st.op = EXEC_NOP;
3224 add_statement ();
3225 }
3226 break;
3227
3228 case ST_IMPLIED_ENDDO:
3229 /* If the do-stmt of this DO construct has a do-construct-name,
3230 the corresponding end-do must be an end-do-stmt (with a matching
3231 name, but in that case we must have seen ST_ENDDO first).
3232 We only complain about this in pedantic mode. */
3233 if (gfc_current_block () != NULL)
3234 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3235 &gfc_current_block()->declared_at);
3236
3237 break;
3238
3239 default:
3240 unexpected_statement (st);
3241 goto loop;
3242 }
3243
3244 pop_state ();
3245 accept_statement (st);
3246 }
3247
3248
3249 /* Parse the statements of OpenMP do/parallel do. */
3250
3251 static gfc_statement
3252 parse_omp_do (gfc_statement omp_st)
3253 {
3254 gfc_statement st;
3255 gfc_code *cp, *np;
3256 gfc_state_data s;
3257
3258 accept_statement (omp_st);
3259
3260 cp = gfc_state_stack->tail;
3261 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3262 np = new_level (cp);
3263 np->op = cp->op;
3264 np->block = NULL;
3265
3266 for (;;)
3267 {
3268 st = next_statement ();
3269 if (st == ST_NONE)
3270 unexpected_eof ();
3271 else if (st == ST_DO)
3272 break;
3273 else
3274 unexpected_statement (st);
3275 }
3276
3277 parse_do_block ();
3278 if (gfc_statement_label != NULL
3279 && gfc_state_stack->previous != NULL
3280 && gfc_state_stack->previous->state == COMP_DO
3281 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3282 {
3283 /* In
3284 DO 100 I=1,10
3285 !$OMP DO
3286 DO J=1,10
3287 ...
3288 100 CONTINUE
3289 there should be no !$OMP END DO. */
3290 pop_state ();
3291 return ST_IMPLIED_ENDDO;
3292 }
3293
3294 check_do_closure ();
3295 pop_state ();
3296
3297 st = next_statement ();
3298 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3299 {
3300 if (new_st.op == EXEC_OMP_END_NOWAIT)
3301 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3302 else
3303 gcc_assert (new_st.op == EXEC_NOP);
3304 gfc_clear_new_st ();
3305 gfc_commit_symbols ();
3306 gfc_warning_check ();
3307 st = next_statement ();
3308 }
3309 return st;
3310 }
3311
3312
3313 /* Parse the statements of OpenMP atomic directive. */
3314
3315 static void
3316 parse_omp_atomic (void)
3317 {
3318 gfc_statement st;
3319 gfc_code *cp, *np;
3320 gfc_state_data s;
3321
3322 accept_statement (ST_OMP_ATOMIC);
3323
3324 cp = gfc_state_stack->tail;
3325 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3326 np = new_level (cp);
3327 np->op = cp->op;
3328 np->block = NULL;
3329
3330 for (;;)
3331 {
3332 st = next_statement ();
3333 if (st == ST_NONE)
3334 unexpected_eof ();
3335 else if (st == ST_ASSIGNMENT)
3336 break;
3337 else
3338 unexpected_statement (st);
3339 }
3340
3341 accept_statement (st);
3342
3343 pop_state ();
3344 }
3345
3346
3347 /* Parse the statements of an OpenMP structured block. */
3348
3349 static void
3350 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3351 {
3352 gfc_statement st, omp_end_st;
3353 gfc_code *cp, *np;
3354 gfc_state_data s;
3355
3356 accept_statement (omp_st);
3357
3358 cp = gfc_state_stack->tail;
3359 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3360 np = new_level (cp);
3361 np->op = cp->op;
3362 np->block = NULL;
3363
3364 switch (omp_st)
3365 {
3366 case ST_OMP_PARALLEL:
3367 omp_end_st = ST_OMP_END_PARALLEL;
3368 break;
3369 case ST_OMP_PARALLEL_SECTIONS:
3370 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3371 break;
3372 case ST_OMP_SECTIONS:
3373 omp_end_st = ST_OMP_END_SECTIONS;
3374 break;
3375 case ST_OMP_ORDERED:
3376 omp_end_st = ST_OMP_END_ORDERED;
3377 break;
3378 case ST_OMP_CRITICAL:
3379 omp_end_st = ST_OMP_END_CRITICAL;
3380 break;
3381 case ST_OMP_MASTER:
3382 omp_end_st = ST_OMP_END_MASTER;
3383 break;
3384 case ST_OMP_SINGLE:
3385 omp_end_st = ST_OMP_END_SINGLE;
3386 break;
3387 case ST_OMP_TASK:
3388 omp_end_st = ST_OMP_END_TASK;
3389 break;
3390 case ST_OMP_WORKSHARE:
3391 omp_end_st = ST_OMP_END_WORKSHARE;
3392 break;
3393 case ST_OMP_PARALLEL_WORKSHARE:
3394 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3395 break;
3396 default:
3397 gcc_unreachable ();
3398 }
3399
3400 do
3401 {
3402 if (workshare_stmts_only)
3403 {
3404 /* Inside of !$omp workshare, only
3405 scalar assignments
3406 array assignments
3407 where statements and constructs
3408 forall statements and constructs
3409 !$omp atomic
3410 !$omp critical
3411 !$omp parallel
3412 are allowed. For !$omp critical these
3413 restrictions apply recursively. */
3414 bool cycle = true;
3415
3416 st = next_statement ();
3417 for (;;)
3418 {
3419 switch (st)
3420 {
3421 case ST_NONE:
3422 unexpected_eof ();
3423
3424 case ST_ASSIGNMENT:
3425 case ST_WHERE:
3426 case ST_FORALL:
3427 accept_statement (st);
3428 break;
3429
3430 case ST_WHERE_BLOCK:
3431 parse_where_block ();
3432 break;
3433
3434 case ST_FORALL_BLOCK:
3435 parse_forall_block ();
3436 break;
3437
3438 case ST_OMP_PARALLEL:
3439 case ST_OMP_PARALLEL_SECTIONS:
3440 parse_omp_structured_block (st, false);
3441 break;
3442
3443 case ST_OMP_PARALLEL_WORKSHARE:
3444 case ST_OMP_CRITICAL:
3445 parse_omp_structured_block (st, true);
3446 break;
3447
3448 case ST_OMP_PARALLEL_DO:
3449 st = parse_omp_do (st);
3450 continue;
3451
3452 case ST_OMP_ATOMIC:
3453 parse_omp_atomic ();
3454 break;
3455
3456 default:
3457 cycle = false;
3458 break;
3459 }
3460
3461 if (!cycle)
3462 break;
3463
3464 st = next_statement ();
3465 }
3466 }
3467 else
3468 st = parse_executable (ST_NONE);
3469 if (st == ST_NONE)
3470 unexpected_eof ();
3471 else if (st == ST_OMP_SECTION
3472 && (omp_st == ST_OMP_SECTIONS
3473 || omp_st == ST_OMP_PARALLEL_SECTIONS))
3474 {
3475 np = new_level (np);
3476 np->op = cp->op;
3477 np->block = NULL;
3478 }
3479 else if (st != omp_end_st)
3480 unexpected_statement (st);
3481 }
3482 while (st != omp_end_st);
3483
3484 switch (new_st.op)
3485 {
3486 case EXEC_OMP_END_NOWAIT:
3487 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3488 break;
3489 case EXEC_OMP_CRITICAL:
3490 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3491 || (new_st.ext.omp_name != NULL
3492 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3493 gfc_error ("Name after !$omp critical and !$omp end critical does "
3494 "not match at %C");
3495 gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3496 break;
3497 case EXEC_OMP_END_SINGLE:
3498 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3499 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3500 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3501 gfc_free_omp_clauses (new_st.ext.omp_clauses);
3502 break;
3503 case EXEC_NOP:
3504 break;
3505 default:
3506 gcc_unreachable ();
3507 }
3508
3509 gfc_clear_new_st ();
3510 gfc_commit_symbols ();
3511 gfc_warning_check ();
3512 pop_state ();
3513 }
3514
3515
3516 /* Accept a series of executable statements. We return the first
3517 statement that doesn't fit to the caller. Any block statements are
3518 passed on to the correct handler, which usually passes the buck
3519 right back here. */
3520
3521 static gfc_statement
3522 parse_executable (gfc_statement st)
3523 {
3524 int close_flag;
3525
3526 if (st == ST_NONE)
3527 st = next_statement ();
3528
3529 for (;;)
3530 {
3531 close_flag = check_do_closure ();
3532 if (close_flag)
3533 switch (st)
3534 {
3535 case ST_GOTO:
3536 case ST_END_PROGRAM:
3537 case ST_RETURN:
3538 case ST_EXIT:
3539 case ST_END_FUNCTION:
3540 case ST_CYCLE:
3541 case ST_PAUSE:
3542 case ST_STOP:
3543 case ST_ERROR_STOP:
3544 case ST_END_SUBROUTINE:
3545
3546 case ST_DO:
3547 case ST_CRITICAL:
3548 case ST_BLOCK:
3549 case ST_FORALL:
3550 case ST_WHERE:
3551 case ST_SELECT_CASE:
3552 gfc_error ("%s statement at %C cannot terminate a non-block "
3553 "DO loop", gfc_ascii_statement (st));
3554 break;
3555
3556 default:
3557 break;
3558 }
3559
3560 switch (st)
3561 {
3562 case ST_NONE:
3563 unexpected_eof ();
3564
3565 case ST_FORMAT:
3566 case ST_DATA:
3567 case ST_ENTRY:
3568 case_executable:
3569 accept_statement (st);
3570 if (close_flag == 1)
3571 return ST_IMPLIED_ENDDO;
3572 break;
3573
3574 case ST_BLOCK:
3575 parse_block_construct ();
3576 break;
3577
3578 case ST_IF_BLOCK:
3579 parse_if_block ();
3580 break;
3581
3582 case ST_SELECT_CASE:
3583 parse_select_block ();
3584 break;
3585
3586 case ST_SELECT_TYPE:
3587 parse_select_type_block();
3588 break;
3589
3590 case ST_DO:
3591 parse_do_block ();
3592 if (check_do_closure () == 1)
3593 return ST_IMPLIED_ENDDO;
3594 break;
3595
3596 case ST_CRITICAL:
3597 parse_critical_block ();
3598 break;
3599
3600 case ST_WHERE_BLOCK:
3601 parse_where_block ();
3602 break;
3603
3604 case ST_FORALL_BLOCK:
3605 parse_forall_block ();
3606 break;
3607
3608 case ST_OMP_PARALLEL:
3609 case ST_OMP_PARALLEL_SECTIONS:
3610 case ST_OMP_SECTIONS:
3611 case ST_OMP_ORDERED:
3612 case ST_OMP_CRITICAL:
3613 case ST_OMP_MASTER:
3614 case ST_OMP_SINGLE:
3615 case ST_OMP_TASK:
3616 parse_omp_structured_block (st, false);
3617 break;
3618
3619 case ST_OMP_WORKSHARE:
3620 case ST_OMP_PARALLEL_WORKSHARE:
3621 parse_omp_structured_block (st, true);
3622 break;
3623
3624 case ST_OMP_DO:
3625 case ST_OMP_PARALLEL_DO:
3626 st = parse_omp_do (st);
3627 if (st == ST_IMPLIED_ENDDO)
3628 return st;
3629 continue;
3630
3631 case ST_OMP_ATOMIC:
3632 parse_omp_atomic ();
3633 break;
3634
3635 default:
3636 return st;
3637 }
3638
3639 st = next_statement ();
3640 }
3641 }
3642
3643
3644 /* Fix the symbols for sibling functions. These are incorrectly added to
3645 the child namespace as the parser didn't know about this procedure. */
3646
3647 static void
3648 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3649 {
3650 gfc_namespace *ns;
3651 gfc_symtree *st;
3652 gfc_symbol *old_sym;
3653
3654 sym->attr.referenced = 1;
3655 for (ns = siblings; ns; ns = ns->sibling)
3656 {
3657 st = gfc_find_symtree (ns->sym_root, sym->name);
3658
3659 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3660 goto fixup_contained;
3661
3662 old_sym = st->n.sym;
3663 if (old_sym->ns == ns
3664 && !old_sym->attr.contained
3665
3666 /* By 14.6.1.3, host association should be excluded
3667 for the following. */
3668 && !(old_sym->attr.external
3669 || (old_sym->ts.type != BT_UNKNOWN
3670 && !old_sym->attr.implicit_type)
3671 || old_sym->attr.flavor == FL_PARAMETER
3672 || old_sym->attr.in_common
3673 || old_sym->attr.in_equivalence
3674 || old_sym->attr.data
3675 || old_sym->attr.dummy
3676 || old_sym->attr.result
3677 || old_sym->attr.dimension
3678 || old_sym->attr.allocatable
3679 || old_sym->attr.intrinsic
3680 || old_sym->attr.generic
3681 || old_sym->attr.flavor == FL_NAMELIST
3682 || old_sym->attr.proc == PROC_ST_FUNCTION))
3683 {
3684 /* Replace it with the symbol from the parent namespace. */
3685 st->n.sym = sym;
3686 sym->refs++;
3687
3688 /* Free the old (local) symbol. */
3689 old_sym->refs--;
3690 if (old_sym->refs == 0)
3691 gfc_free_symbol (old_sym);
3692 }
3693
3694 fixup_contained:
3695 /* Do the same for any contained procedures. */
3696 gfc_fixup_sibling_symbols (sym, ns->contained);
3697 }
3698 }
3699
3700 static void
3701 parse_contained (int module)
3702 {
3703 gfc_namespace *ns, *parent_ns, *tmp;
3704 gfc_state_data s1, s2;
3705 gfc_statement st;
3706 gfc_symbol *sym;
3707 gfc_entry_list *el;
3708 int contains_statements = 0;
3709 int seen_error = 0;
3710
3711 push_state (&s1, COMP_CONTAINS, NULL);
3712 parent_ns = gfc_current_ns;
3713
3714 do
3715 {
3716 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3717
3718 gfc_current_ns->sibling = parent_ns->contained;
3719 parent_ns->contained = gfc_current_ns;
3720
3721 next:
3722 /* Process the next available statement. We come here if we got an error
3723 and rejected the last statement. */
3724 st = next_statement ();
3725
3726 switch (st)
3727 {
3728 case ST_NONE:
3729 unexpected_eof ();
3730
3731 case ST_FUNCTION:
3732 case ST_SUBROUTINE:
3733 contains_statements = 1;
3734 accept_statement (st);
3735
3736 push_state (&s2,
3737 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3738 gfc_new_block);
3739
3740 /* For internal procedures, create/update the symbol in the
3741 parent namespace. */
3742
3743 if (!module)
3744 {
3745 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3746 gfc_error ("Contained procedure '%s' at %C is already "
3747 "ambiguous", gfc_new_block->name);
3748 else
3749 {
3750 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3751 &gfc_new_block->declared_at) ==
3752 SUCCESS)
3753 {
3754 if (st == ST_FUNCTION)
3755 gfc_add_function (&sym->attr, sym->name,
3756 &gfc_new_block->declared_at);
3757 else
3758 gfc_add_subroutine (&sym->attr, sym->name,
3759 &gfc_new_block->declared_at);
3760 }
3761 }
3762
3763 gfc_commit_symbols ();
3764 }
3765 else
3766 sym = gfc_new_block;
3767
3768 /* Mark this as a contained function, so it isn't replaced
3769 by other module functions. */
3770 sym->attr.contained = 1;
3771 sym->attr.referenced = 1;
3772
3773 parse_progunit (ST_NONE);
3774
3775 /* Fix up any sibling functions that refer to this one. */
3776 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3777 /* Or refer to any of its alternate entry points. */
3778 for (el = gfc_current_ns->entries; el; el = el->next)
3779 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3780
3781 gfc_current_ns->code = s2.head;
3782 gfc_current_ns = parent_ns;
3783
3784 pop_state ();
3785 break;
3786
3787 /* These statements are associated with the end of the host unit. */
3788 case ST_END_FUNCTION:
3789 case ST_END_MODULE:
3790 case ST_END_PROGRAM:
3791 case ST_END_SUBROUTINE:
3792 accept_statement (st);
3793 break;
3794
3795 default:
3796 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3797 gfc_ascii_statement (st));
3798 reject_statement ();
3799 seen_error = 1;
3800 goto next;
3801 break;
3802 }
3803 }
3804 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3805 && st != ST_END_MODULE && st != ST_END_PROGRAM);
3806
3807 /* The first namespace in the list is guaranteed to not have
3808 anything (worthwhile) in it. */
3809 tmp = gfc_current_ns;
3810 gfc_current_ns = parent_ns;
3811 if (seen_error && tmp->refs > 1)
3812 gfc_free_namespace (tmp);
3813
3814 ns = gfc_current_ns->contained;
3815 gfc_current_ns->contained = ns->sibling;
3816 gfc_free_namespace (ns);
3817
3818 pop_state ();
3819 if (!contains_statements)
3820 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3821 "FUNCTION or SUBROUTINE statement at %C");
3822 }
3823
3824
3825 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
3826
3827 static void
3828 parse_progunit (gfc_statement st)
3829 {
3830 gfc_state_data *p;
3831 int n;
3832
3833 st = parse_spec (st);
3834 switch (st)
3835 {
3836 case ST_NONE:
3837 unexpected_eof ();
3838
3839 case ST_CONTAINS:
3840 /* This is not allowed within BLOCK! */
3841 if (gfc_current_state () != COMP_BLOCK)
3842 goto contains;
3843 break;
3844
3845 case_end:
3846 accept_statement (st);
3847 goto done;
3848
3849 default:
3850 break;
3851 }
3852
3853 if (gfc_current_state () == COMP_FUNCTION)
3854 gfc_check_function_type (gfc_current_ns);
3855
3856 loop:
3857 for (;;)
3858 {
3859 st = parse_executable (st);
3860
3861 switch (st)
3862 {
3863 case ST_NONE:
3864 unexpected_eof ();
3865
3866 case ST_CONTAINS:
3867 /* This is not allowed within BLOCK! */
3868 if (gfc_current_state () != COMP_BLOCK)
3869 goto contains;
3870 break;
3871
3872 case_end:
3873 accept_statement (st);
3874 goto done;
3875
3876 default:
3877 break;
3878 }
3879
3880 unexpected_statement (st);
3881 reject_statement ();
3882 st = next_statement ();
3883 }
3884
3885 contains:
3886 n = 0;
3887
3888 for (p = gfc_state_stack; p; p = p->previous)
3889 if (p->state == COMP_CONTAINS)
3890 n++;
3891
3892 if (gfc_find_state (COMP_MODULE) == SUCCESS)
3893 n--;
3894
3895 if (n > 0)
3896 {
3897 gfc_error ("CONTAINS statement at %C is already in a contained "
3898 "program unit");
3899 st = next_statement ();
3900 goto loop;
3901 }
3902
3903 parse_contained (0);
3904
3905 done:
3906 gfc_current_ns->code = gfc_state_stack->head;
3907 }
3908
3909
3910 /* Come here to complain about a global symbol already in use as
3911 something else. */
3912
3913 void
3914 gfc_global_used (gfc_gsymbol *sym, locus *where)
3915 {
3916 const char *name;
3917
3918 if (where == NULL)
3919 where = &gfc_current_locus;
3920
3921 switch(sym->type)
3922 {
3923 case GSYM_PROGRAM:
3924 name = "PROGRAM";
3925 break;
3926 case GSYM_FUNCTION:
3927 name = "FUNCTION";
3928 break;
3929 case GSYM_SUBROUTINE:
3930 name = "SUBROUTINE";
3931 break;
3932 case GSYM_COMMON:
3933 name = "COMMON";
3934 break;
3935 case GSYM_BLOCK_DATA:
3936 name = "BLOCK DATA";
3937 break;
3938 case GSYM_MODULE:
3939 name = "MODULE";
3940 break;
3941 default:
3942 gfc_internal_error ("gfc_global_used(): Bad type");
3943 name = NULL;
3944 }
3945
3946 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3947 sym->name, where, name, &sym->where);
3948 }
3949
3950
3951 /* Parse a block data program unit. */
3952
3953 static void
3954 parse_block_data (void)
3955 {
3956 gfc_statement st;
3957 static locus blank_locus;
3958 static int blank_block=0;
3959 gfc_gsymbol *s;
3960
3961 gfc_current_ns->proc_name = gfc_new_block;
3962 gfc_current_ns->is_block_data = 1;
3963
3964 if (gfc_new_block == NULL)
3965 {
3966 if (blank_block)
3967 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3968 "prior BLOCK DATA at %L", &blank_locus);
3969 else
3970 {
3971 blank_block = 1;
3972 blank_locus = gfc_current_locus;
3973 }
3974 }
3975 else
3976 {
3977 s = gfc_get_gsymbol (gfc_new_block->name);
3978 if (s->defined
3979 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3980 gfc_global_used(s, NULL);
3981 else
3982 {
3983 s->type = GSYM_BLOCK_DATA;
3984 s->where = gfc_current_locus;
3985 s->defined = 1;
3986 }
3987 }
3988
3989 st = parse_spec (ST_NONE);
3990
3991 while (st != ST_END_BLOCK_DATA)
3992 {
3993 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3994 gfc_ascii_statement (st));
3995 reject_statement ();
3996 st = next_statement ();
3997 }
3998 }
3999
4000
4001 /* Parse a module subprogram. */
4002
4003 static void
4004 parse_module (void)
4005 {
4006 gfc_statement st;
4007 gfc_gsymbol *s;
4008
4009 s = gfc_get_gsymbol (gfc_new_block->name);
4010 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4011 gfc_global_used(s, NULL);
4012 else
4013 {
4014 s->type = GSYM_MODULE;
4015 s->where = gfc_current_locus;
4016 s->defined = 1;
4017 }
4018
4019 st = parse_spec (ST_NONE);
4020
4021 loop:
4022 switch (st)
4023 {
4024 case ST_NONE:
4025 unexpected_eof ();
4026
4027 case ST_CONTAINS:
4028 parse_contained (1);
4029 break;
4030
4031 case ST_END_MODULE:
4032 accept_statement (st);
4033 break;
4034
4035 default:
4036 gfc_error ("Unexpected %s statement in MODULE at %C",
4037 gfc_ascii_statement (st));
4038
4039 reject_statement ();
4040 st = next_statement ();
4041 goto loop;
4042 }
4043
4044 s->ns = gfc_current_ns;
4045 }
4046
4047
4048 /* Add a procedure name to the global symbol table. */
4049
4050 static void
4051 add_global_procedure (int sub)
4052 {
4053 gfc_gsymbol *s;
4054
4055 s = gfc_get_gsymbol(gfc_new_block->name);
4056
4057 if (s->defined
4058 || (s->type != GSYM_UNKNOWN
4059 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4060 gfc_global_used(s, NULL);
4061 else
4062 {
4063 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4064 s->where = gfc_current_locus;
4065 s->defined = 1;
4066 s->ns = gfc_current_ns;
4067 }
4068 }
4069
4070
4071 /* Add a program to the global symbol table. */
4072
4073 static void
4074 add_global_program (void)
4075 {
4076 gfc_gsymbol *s;
4077
4078 if (gfc_new_block == NULL)
4079 return;
4080 s = gfc_get_gsymbol (gfc_new_block->name);
4081
4082 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4083 gfc_global_used(s, NULL);
4084 else
4085 {
4086 s->type = GSYM_PROGRAM;
4087 s->where = gfc_current_locus;
4088 s->defined = 1;
4089 s->ns = gfc_current_ns;
4090 }
4091 }
4092
4093
4094 /* Resolve all the program units when whole file scope option
4095 is active. */
4096 static void
4097 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4098 {
4099 gfc_free_dt_list ();
4100 gfc_current_ns = gfc_global_ns_list;
4101 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4102 {
4103 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4104 gfc_resolve (gfc_current_ns);
4105 gfc_current_ns->derived_types = gfc_derived_types;
4106 gfc_derived_types = NULL;
4107 }
4108 }
4109
4110
4111 static void
4112 clean_up_modules (gfc_gsymbol *gsym)
4113 {
4114 if (gsym == NULL)
4115 return;
4116
4117 clean_up_modules (gsym->left);
4118 clean_up_modules (gsym->right);
4119
4120 if (gsym->type != GSYM_MODULE || !gsym->ns)
4121 return;
4122
4123 gfc_current_ns = gsym->ns;
4124 gfc_derived_types = gfc_current_ns->derived_types;
4125 gfc_done_2 ();
4126 gsym->ns = NULL;
4127 return;
4128 }
4129
4130
4131 /* Translate all the program units when whole file scope option
4132 is active. This could be in a different order to resolution if
4133 there are forward references in the file. */
4134 static void
4135 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4136 {
4137 int errors;
4138
4139 gfc_current_ns = gfc_global_ns_list;
4140 gfc_get_errors (NULL, &errors);
4141
4142 for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4143 {
4144 gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4145 gfc_derived_types = gfc_current_ns->derived_types;
4146 gfc_generate_code (gfc_current_ns);
4147 gfc_current_ns->translated = 1;
4148 }
4149
4150 /* Clean up all the namespaces after translation. */
4151 gfc_current_ns = gfc_global_ns_list;
4152 for (;gfc_current_ns;)
4153 {
4154 gfc_namespace *ns = gfc_current_ns->sibling;
4155 gfc_derived_types = gfc_current_ns->derived_types;
4156 gfc_done_2 ();
4157 gfc_current_ns = ns;
4158 }
4159
4160 clean_up_modules (gfc_gsym_root);
4161 }
4162
4163
4164 /* Top level parser. */
4165
4166 gfc_try
4167 gfc_parse_file (void)
4168 {
4169 int seen_program, errors_before, errors;
4170 gfc_state_data top, s;
4171 gfc_statement st;
4172 locus prog_locus;
4173 gfc_namespace *next;
4174
4175 gfc_start_source_files ();
4176
4177 top.state = COMP_NONE;
4178 top.sym = NULL;
4179 top.previous = NULL;
4180 top.head = top.tail = NULL;
4181 top.do_variable = NULL;
4182
4183 gfc_state_stack = &top;
4184
4185 gfc_clear_new_st ();
4186
4187 gfc_statement_label = NULL;
4188
4189 if (setjmp (eof_buf))
4190 return FAILURE; /* Come here on unexpected EOF */
4191
4192 /* Prepare the global namespace that will contain the
4193 program units. */
4194 gfc_global_ns_list = next = NULL;
4195
4196 seen_program = 0;
4197
4198 /* Exit early for empty files. */
4199 if (gfc_at_eof ())
4200 goto done;
4201
4202 loop:
4203 gfc_init_2 ();
4204 st = next_statement ();
4205 switch (st)
4206 {
4207 case ST_NONE:
4208 gfc_done_2 ();
4209 goto done;
4210
4211 case ST_PROGRAM:
4212 if (seen_program)
4213 goto duplicate_main;
4214 seen_program = 1;
4215 prog_locus = gfc_current_locus;
4216
4217 push_state (&s, COMP_PROGRAM, gfc_new_block);
4218 main_program_symbol(gfc_current_ns, gfc_new_block->name);
4219 accept_statement (st);
4220 add_global_program ();
4221 parse_progunit (ST_NONE);
4222 if (gfc_option.flag_whole_file)
4223 goto prog_units;
4224 break;
4225
4226 case ST_SUBROUTINE:
4227 add_global_procedure (1);
4228 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4229 accept_statement (st);
4230 parse_progunit (ST_NONE);
4231 if (gfc_option.flag_whole_file)
4232 goto prog_units;
4233 break;
4234
4235 case ST_FUNCTION:
4236 add_global_procedure (0);
4237 push_state (&s, COMP_FUNCTION, gfc_new_block);
4238 accept_statement (st);
4239 parse_progunit (ST_NONE);
4240 if (gfc_option.flag_whole_file)
4241 goto prog_units;
4242 break;
4243
4244 case ST_BLOCK_DATA:
4245 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4246 accept_statement (st);
4247 parse_block_data ();
4248 break;
4249
4250 case ST_MODULE:
4251 push_state (&s, COMP_MODULE, gfc_new_block);
4252 accept_statement (st);
4253
4254 gfc_get_errors (NULL, &errors_before);
4255 parse_module ();
4256 break;
4257
4258 /* Anything else starts a nameless main program block. */
4259 default:
4260 if (seen_program)
4261 goto duplicate_main;
4262 seen_program = 1;
4263 prog_locus = gfc_current_locus;
4264
4265 push_state (&s, COMP_PROGRAM, gfc_new_block);
4266 main_program_symbol (gfc_current_ns, "MAIN__");
4267 parse_progunit (st);
4268 if (gfc_option.flag_whole_file)
4269 goto prog_units;
4270 break;
4271 }
4272
4273 /* Handle the non-program units. */
4274 gfc_current_ns->code = s.head;
4275
4276 gfc_resolve (gfc_current_ns);
4277
4278 /* Dump the parse tree if requested. */
4279 if (gfc_option.dump_parse_tree)
4280 gfc_dump_parse_tree (gfc_current_ns, stdout);
4281
4282 gfc_get_errors (NULL, &errors);
4283 if (s.state == COMP_MODULE)
4284 {
4285 gfc_dump_module (s.sym->name, errors_before == errors);
4286 if (errors == 0)
4287 gfc_generate_module_code (gfc_current_ns);
4288 pop_state ();
4289 if (!gfc_option.flag_whole_file)
4290 gfc_done_2 ();
4291 else
4292 {
4293 gfc_current_ns->derived_types = gfc_derived_types;
4294 gfc_derived_types = NULL;
4295 gfc_current_ns = NULL;
4296 }
4297 }
4298 else
4299 {
4300 if (errors == 0)
4301 gfc_generate_code (gfc_current_ns);
4302 pop_state ();
4303 gfc_done_2 ();
4304 }
4305
4306 goto loop;
4307
4308 prog_units:
4309 /* The main program and non-contained procedures are put
4310 in the global namespace list, so that they can be processed
4311 later and all their interfaces resolved. */
4312 gfc_current_ns->code = s.head;
4313 if (next)
4314 next->sibling = gfc_current_ns;
4315 else
4316 gfc_global_ns_list = gfc_current_ns;
4317
4318 next = gfc_current_ns;
4319
4320 pop_state ();
4321 goto loop;
4322
4323 done:
4324
4325 if (!gfc_option.flag_whole_file)
4326 goto termination;
4327
4328 /* Do the resolution. */
4329 resolve_all_program_units (gfc_global_ns_list);
4330
4331 /* Do the parse tree dump. */
4332 gfc_current_ns
4333 = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
4334
4335 for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4336 {
4337 gfc_dump_parse_tree (gfc_current_ns, stdout);
4338 fputs ("------------------------------------------\n\n", stdout);
4339 }
4340
4341 /* Do the translation. */
4342 translate_all_program_units (gfc_global_ns_list);
4343
4344 termination:
4345
4346 gfc_end_source_files ();
4347 return SUCCESS;
4348
4349 duplicate_main:
4350 /* If we see a duplicate main program, shut down. If the second
4351 instance is an implied main program, i.e. data decls or executable
4352 statements, we're in for lots of errors. */
4353 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4354 reject_statement ();
4355 gfc_done_2 ();
4356 return SUCCESS;
4357 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org