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