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