2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
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
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
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/>. */
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. */
34 gfc_st_label
*gfc_statement_label
;
36 static locus label_locus
;
37 static jmp_buf eof_buf
;
39 gfc_state_data
*gfc_state_stack
;
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);
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
54 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
69 gfc_current_locus
= *old_locus
;
77 /* Figure out what the next statement is, (mostly) regardless of
78 proper ordering. The do...while(0) is there to prevent if/else
81 #define match(keyword, subr, st) \
83 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
86 undo_new_statement (); \
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. */
100 decode_specification_statement (void)
106 if (gfc_match_eos () == MATCH_YES
)
109 old_locus
= gfc_current_locus
;
111 match ("import", gfc_match_import
, ST_IMPORT
);
112 match ("use", gfc_match_use
, ST_USE
);
114 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
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
);
121 /* General statement matching: Instead of testing every possible
122 statement, we eliminate most possibilities by peeking at the
125 c
= gfc_peek_ascii_char ();
130 match ("abstract% interface", gfc_match_abstract_interface
,
132 match ("allocatable", gfc_match_asynchronous
, ST_ATTR_DECL
);
133 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
137 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
144 match ("data", gfc_match_data
, ST_DATA
);
145 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
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
);
156 match ("format", gfc_match_format
, ST_FORMAT
);
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
);
174 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
178 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
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
)
186 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
187 if (gfc_match_public (&st
) == MATCH_YES
)
189 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
196 match ("save", gfc_match_save
, ST_ATTR_DECL
);
200 match ("target", gfc_match_target
, ST_ATTR_DECL
);
201 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
208 match ("value", gfc_match_value
, ST_ATTR_DECL
);
209 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
216 /* This is not a specification statement. See if any of the matchers
217 has stored an error message of some sort. */
221 gfc_buffer_error (0);
222 gfc_current_locus
= old_locus
;
224 return ST_GET_FCN_CHARACTERISTICS
;
228 /* This is the primary 'decode_statement'. */
230 decode_statement (void)
241 gfc_clear_error (); /* Clear any pending errors. */
242 gfc_clear_warning (); /* Clear any pending warnings. */
244 gfc_matching_function
= false;
246 if (gfc_match_eos () == MATCH_YES
)
249 if (gfc_current_state () == COMP_FUNCTION
250 && gfc_current_block ()->result
->ts
.kind
== -1)
251 return decode_specification_statement ();
253 old_locus
= gfc_current_locus
;
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. */
259 if (gfc_current_state () == COMP_NONE
260 || gfc_current_state () == COMP_INTERFACE
261 || gfc_current_state () == COMP_CONTAINS
)
263 gfc_matching_function
= true;
264 m
= gfc_match_function_decl ();
267 else if (m
== MATCH_ERROR
)
271 gfc_current_locus
= old_locus
;
273 gfc_matching_function
= false;
276 /* Match statements whose error messages are meant to be overwritten
277 by something better. */
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
);
283 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
284 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
286 /* Try to match a subroutine statement, which has the same optional
287 prefixes that functions can have. */
289 if (gfc_match_subroutine () == MATCH_YES
)
290 return ST_SUBROUTINE
;
292 gfc_current_locus
= old_locus
;
294 /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
295 might begin with a block label. The match functions for these
296 statements are unusual in that their keyword is not seen before
297 the matcher is called. */
299 if (gfc_match_if (&st
) == MATCH_YES
)
302 gfc_current_locus
= old_locus
;
304 if (gfc_match_where (&st
) == MATCH_YES
)
307 gfc_current_locus
= old_locus
;
309 if (gfc_match_forall (&st
) == MATCH_YES
)
312 gfc_current_locus
= old_locus
;
314 match (NULL
, gfc_match_block
, ST_BLOCK
);
315 match (NULL
, gfc_match_do
, ST_DO
);
316 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
317 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
319 /* General statement matching: Instead of testing every possible
320 statement, we eliminate most possibilities by peeking at the
323 c
= gfc_peek_ascii_char ();
328 match ("abstract% interface", gfc_match_abstract_interface
,
330 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
331 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
332 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
333 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
337 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
338 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
339 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
343 match ("call", gfc_match_call
, ST_CALL
);
344 match ("close", gfc_match_close
, ST_CLOSE
);
345 match ("continue", gfc_match_continue
, ST_CONTINUE
);
346 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
347 match ("case", gfc_match_case
, ST_CASE
);
348 match ("common", gfc_match_common
, ST_COMMON
);
349 match ("contains", gfc_match_eos
, ST_CONTAINS
);
350 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
354 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
355 match ("data", gfc_match_data
, ST_DATA
);
356 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
360 match ("end file", gfc_match_endfile
, ST_END_FILE
);
361 match ("exit", gfc_match_exit
, ST_EXIT
);
362 match ("else", gfc_match_else
, ST_ELSE
);
363 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
364 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
365 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
367 if (gfc_match_end (&st
) == MATCH_YES
)
370 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
371 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
372 match ("external", gfc_match_external
, ST_ATTR_DECL
);
376 match ("final", gfc_match_final_decl
, ST_FINAL
);
377 match ("flush", gfc_match_flush
, ST_FLUSH
);
378 match ("format", gfc_match_format
, ST_FORMAT
);
382 match ("generic", gfc_match_generic
, ST_GENERIC
);
383 match ("go to", gfc_match_goto
, ST_GOTO
);
387 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
388 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
389 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
390 match ("import", gfc_match_import
, ST_IMPORT
);
391 match ("interface", gfc_match_interface
, ST_INTERFACE
);
392 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
393 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
397 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
398 match ("module", gfc_match_module
, ST_MODULE
);
402 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
403 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
407 match ("open", gfc_match_open
, ST_OPEN
);
408 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
412 match ("print", gfc_match_print
, ST_WRITE
);
413 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
414 match ("pause", gfc_match_pause
, ST_PAUSE
);
415 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
416 if (gfc_match_private (&st
) == MATCH_YES
)
418 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
419 match ("program", gfc_match_program
, ST_PROGRAM
);
420 if (gfc_match_public (&st
) == MATCH_YES
)
422 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
426 match ("read", gfc_match_read
, ST_READ
);
427 match ("return", gfc_match_return
, ST_RETURN
);
428 match ("rewind", gfc_match_rewind
, ST_REWIND
);
432 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
433 match ("stop", gfc_match_stop
, ST_STOP
);
434 match ("save", gfc_match_save
, ST_ATTR_DECL
);
438 match ("target", gfc_match_target
, ST_ATTR_DECL
);
439 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
440 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
444 match ("use", gfc_match_use
, ST_USE
);
448 match ("value", gfc_match_value
, ST_ATTR_DECL
);
449 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
453 match ("wait", gfc_match_wait
, ST_WAIT
);
454 match ("write", gfc_match_write
, ST_WRITE
);
458 /* All else has failed, so give up. See if any of the matchers has
459 stored an error message of some sort. */
461 if (gfc_error_check () == 0)
462 gfc_error_now ("Unclassifiable statement at %C");
466 gfc_error_recovery ();
472 decode_omp_directive (void)
481 gfc_clear_error (); /* Clear any pending errors. */
482 gfc_clear_warning (); /* Clear any pending warnings. */
486 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
487 "or ELEMENTAL procedures");
488 gfc_error_recovery ();
492 old_locus
= gfc_current_locus
;
494 /* General OpenMP directive matching: Instead of testing every possible
495 statement, we eliminate most possibilities by peeking at the
498 c
= gfc_peek_ascii_char ();
503 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
506 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
509 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
512 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
515 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
516 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
517 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
518 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
519 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
520 match ("end parallel sections", gfc_match_omp_eos
,
521 ST_OMP_END_PARALLEL_SECTIONS
);
522 match ("end parallel workshare", gfc_match_omp_eos
,
523 ST_OMP_END_PARALLEL_WORKSHARE
);
524 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
525 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
526 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
527 match ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
528 match ("end workshare", gfc_match_omp_end_nowait
,
529 ST_OMP_END_WORKSHARE
);
532 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
535 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
538 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
541 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
542 match ("parallel sections", gfc_match_omp_parallel_sections
,
543 ST_OMP_PARALLEL_SECTIONS
);
544 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
545 ST_OMP_PARALLEL_WORKSHARE
);
546 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
549 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
550 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
551 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
554 match ("task", gfc_match_omp_task
, ST_OMP_TASK
);
555 match ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
556 match ("threadprivate", gfc_match_omp_threadprivate
,
557 ST_OMP_THREADPRIVATE
);
559 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
563 /* All else has failed, so give up. See if any of the matchers has
564 stored an error message of some sort. */
566 if (gfc_error_check () == 0)
567 gfc_error_now ("Unclassifiable OpenMP directive at %C");
571 gfc_error_recovery ();
577 decode_gcc_attribute (void)
585 gfc_clear_error (); /* Clear any pending errors. */
586 gfc_clear_warning (); /* Clear any pending warnings. */
587 old_locus
= gfc_current_locus
;
589 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
591 /* All else has failed, so give up. See if any of the matchers has
592 stored an error message of some sort. */
594 if (gfc_error_check () == 0)
595 gfc_error_now ("Unclassifiable GCC directive at %C");
599 gfc_error_recovery ();
607 /* Get the next statement in free form source. */
616 at_bol
= gfc_at_bol ();
617 gfc_gobble_whitespace ();
619 c
= gfc_peek_ascii_char ();
625 /* Found a statement label? */
626 m
= gfc_match_st_label (&gfc_statement_label
);
628 d
= gfc_peek_ascii_char ();
629 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
631 gfc_match_small_literal_int (&i
, &cnt
);
634 gfc_error_now ("Too many digits in statement label at %C");
637 gfc_error_now ("Zero is not a valid statement label at %C");
640 c
= gfc_next_ascii_char ();
643 if (!gfc_is_whitespace (c
))
644 gfc_error_now ("Non-numeric character in statement label at %C");
650 label_locus
= gfc_current_locus
;
652 gfc_gobble_whitespace ();
654 if (at_bol
&& gfc_peek_ascii_char () == ';')
656 gfc_error_now ("Semicolon at %C needs to be preceded by "
658 gfc_next_ascii_char (); /* Eat up the semicolon. */
662 if (gfc_match_eos () == MATCH_YES
)
664 gfc_warning_now ("Ignoring statement label in empty statement "
665 "at %L", &label_locus
);
666 gfc_free_st_label (gfc_statement_label
);
667 gfc_statement_label
= NULL
;
674 /* Comments have already been skipped by the time we get here,
675 except for GCC attributes and OpenMP directives. */
677 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
678 c
= gfc_peek_ascii_char ();
684 c
= gfc_next_ascii_char ();
685 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
686 gcc_assert (c
== "gcc$"[i
]);
688 gfc_gobble_whitespace ();
689 return decode_gcc_attribute ();
692 else if (c
== '$' && gfc_option
.flag_openmp
)
696 c
= gfc_next_ascii_char ();
697 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
698 gcc_assert (c
== "$omp"[i
]);
700 gcc_assert (c
== ' ' || c
== '\t');
701 gfc_gobble_whitespace ();
702 return decode_omp_directive ();
708 if (at_bol
&& c
== ';')
710 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
711 gfc_next_ascii_char (); /* Eat up the semicolon. */
715 return decode_statement ();
719 /* Get the next statement in fixed-form source. */
724 int label
, digit_flag
, i
;
729 return decode_statement ();
731 /* Skip past the current label field, parsing a statement label if
732 one is there. This is a weird number parser, since the number is
733 contained within five columns and can have any kind of embedded
734 spaces. We also check for characters that make the rest of the
740 for (i
= 0; i
< 5; i
++)
742 c
= gfc_next_char_literal (0);
759 label
= label
* 10 + ((unsigned char) c
- '0');
760 label_locus
= gfc_current_locus
;
764 /* Comments have already been skipped by the time we get
765 here, except for GCC attributes and OpenMP directives. */
768 c
= gfc_next_char_literal (0);
770 if (TOLOWER (c
) == 'g')
772 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (0))
773 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
775 return decode_gcc_attribute ();
777 else if (c
== '$' && gfc_option
.flag_openmp
)
779 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (0))
780 gcc_assert ((char) gfc_wide_tolower (c
) == "$omp"[i
]);
782 if (c
!= ' ' && c
!= '0')
784 gfc_buffer_error (0);
785 gfc_error ("Bad continuation line at %C");
789 return decode_omp_directive ();
793 /* Comments have already been skipped by the time we get
794 here so don't bother checking for them. */
797 gfc_buffer_error (0);
798 gfc_error ("Non-numeric character in statement label at %C");
806 gfc_warning_now ("Zero is not a valid statement label at %C");
809 /* We've found a valid statement label. */
810 gfc_statement_label
= gfc_get_st_label (label
);
814 /* Since this line starts a statement, it cannot be a continuation
815 of a previous statement. If we see something here besides a
816 space or zero, it must be a bad continuation line. */
818 c
= gfc_next_char_literal (0);
822 if (c
!= ' ' && c
!= '0')
824 gfc_buffer_error (0);
825 gfc_error ("Bad continuation line at %C");
829 /* Now that we've taken care of the statement label columns, we have
830 to make sure that the first nonblank character is not a '!'. If
831 it is, the rest of the line is a comment. */
835 loc
= gfc_current_locus
;
836 c
= gfc_next_char_literal (0);
838 while (gfc_is_whitespace (c
));
842 gfc_current_locus
= loc
;
846 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
850 if (gfc_match_eos () == MATCH_YES
)
853 /* At this point, we've got a nonblank statement to parse. */
854 return decode_statement ();
858 gfc_warning_now ("Ignoring statement label in empty statement at %L",
861 gfc_current_locus
.lb
->truncated
= 0;
867 /* Return the next non-ST_NONE statement to the caller. We also worry
868 about including files and the ends of include files at this stage. */
871 next_statement (void)
876 gfc_new_block
= NULL
;
878 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
881 gfc_statement_label
= NULL
;
882 gfc_buffer_error (1);
887 gfc_skip_comments ();
895 if (gfc_define_undef_line ())
898 old_locus
= gfc_current_locus
;
900 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
906 gfc_buffer_error (0);
908 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
910 gfc_free_st_label (gfc_statement_label
);
911 gfc_statement_label
= NULL
;
912 gfc_current_locus
= old_locus
;
916 check_statement_label (st
);
922 /****************************** Parser ***********************************/
924 /* The parser subroutines are of type 'try' that fail if the file ends
927 /* Macros that expand to case-labels for various classes of
928 statements. Start with executable statements that directly do
931 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
932 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
933 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
934 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
935 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
936 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
937 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
938 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
939 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT
941 /* Statements that mark other executable statements. */
943 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
944 case ST_IF_BLOCK: case ST_BLOCK: \
945 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
946 case ST_OMP_PARALLEL: \
947 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
948 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
949 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
950 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
953 /* Declaration statements */
955 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
956 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
957 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
960 /* Block end statements. Errors associated with interchanging these
961 are detected in gfc_match_end(). */
963 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
964 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
968 /* Push a new state onto the stack. */
971 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
973 p
->state
= new_state
;
974 p
->previous
= gfc_state_stack
;
976 p
->head
= p
->tail
= NULL
;
977 p
->do_variable
= NULL
;
982 /* Pop the current state. */
986 gfc_state_stack
= gfc_state_stack
->previous
;
990 /* Try to find the given state in the state stack. */
993 gfc_find_state (gfc_compile_state state
)
997 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
998 if (p
->state
== state
)
1001 return (p
== NULL
) ? FAILURE
: SUCCESS
;
1005 /* Starts a new level in the statement list. */
1008 new_level (gfc_code
*q
)
1012 p
= q
->block
= gfc_get_code ();
1014 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1020 /* Add the current new_st code structure and adds it to the current
1021 program unit. As a side-effect, it zeroes the new_st. */
1024 add_statement (void)
1028 p
= gfc_get_code ();
1031 p
->loc
= gfc_current_locus
;
1033 if (gfc_state_stack
->head
== NULL
)
1034 gfc_state_stack
->head
= p
;
1036 gfc_state_stack
->tail
->next
= p
;
1038 while (p
->next
!= NULL
)
1041 gfc_state_stack
->tail
= p
;
1043 gfc_clear_new_st ();
1049 /* Frees everything associated with the current statement. */
1052 undo_new_statement (void)
1054 gfc_free_statements (new_st
.block
);
1055 gfc_free_statements (new_st
.next
);
1056 gfc_free_statement (&new_st
);
1057 gfc_clear_new_st ();
1061 /* If the current statement has a statement label, make sure that it
1062 is allowed to, or should have one. */
1065 check_statement_label (gfc_statement st
)
1069 if (gfc_statement_label
== NULL
)
1071 if (st
== ST_FORMAT
)
1072 gfc_error ("FORMAT statement at %L does not have a statement label",
1079 case ST_END_PROGRAM
:
1080 case ST_END_FUNCTION
:
1081 case ST_END_SUBROUTINE
:
1087 type
= ST_LABEL_TARGET
;
1091 type
= ST_LABEL_FORMAT
;
1094 /* Statement labels are not restricted from appearing on a
1095 particular line. However, there are plenty of situations
1096 where the resulting label can't be referenced. */
1099 type
= ST_LABEL_BAD_TARGET
;
1103 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1105 new_st
.here
= gfc_statement_label
;
1109 /* Figures out what the enclosing program unit is. This will be a
1110 function, subroutine, program, block data or module. */
1113 gfc_enclosing_unit (gfc_compile_state
* result
)
1117 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1118 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1119 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1120 || p
->state
== COMP_PROGRAM
)
1129 *result
= COMP_PROGRAM
;
1134 /* Translate a statement enum to a string. */
1137 gfc_ascii_statement (gfc_statement st
)
1143 case ST_ARITHMETIC_IF
:
1144 p
= _("arithmetic IF");
1150 p
= _("attribute declaration");
1183 p
= _("data declaration");
1191 case ST_DERIVED_DECL
:
1192 p
= _("derived type declaration");
1209 case ST_END_BLOCK_DATA
:
1210 p
= "END BLOCK DATA";
1221 case ST_END_FUNCTION
:
1227 case ST_END_INTERFACE
:
1228 p
= "END INTERFACE";
1233 case ST_END_PROGRAM
:
1239 case ST_END_SUBROUTINE
:
1240 p
= "END SUBROUTINE";
1251 case ST_EQUIVALENCE
:
1260 case ST_FORALL_BLOCK
: /* Fall through */
1282 case ST_IMPLICIT_NONE
:
1283 p
= "IMPLICIT NONE";
1285 case ST_IMPLIED_ENDDO
:
1286 p
= _("implied END DO");
1312 case ST_MODULE_PROC
:
1313 p
= "MODULE PROCEDURE";
1351 case ST_WHERE_BLOCK
: /* Fall through */
1362 p
= _("assignment");
1364 case ST_POINTER_ASSIGNMENT
:
1365 p
= _("pointer assignment");
1367 case ST_SELECT_CASE
:
1370 case ST_SELECT_TYPE
:
1385 case ST_STATEMENT_FUNCTION
:
1386 p
= "STATEMENT FUNCTION";
1388 case ST_LABEL_ASSIGNMENT
:
1389 p
= "LABEL ASSIGNMENT";
1392 p
= "ENUM DEFINITION";
1395 p
= "ENUMERATOR DEFINITION";
1403 case ST_OMP_BARRIER
:
1404 p
= "!$OMP BARRIER";
1406 case ST_OMP_CRITICAL
:
1407 p
= "!$OMP CRITICAL";
1412 case ST_OMP_END_CRITICAL
:
1413 p
= "!$OMP END CRITICAL";
1418 case ST_OMP_END_MASTER
:
1419 p
= "!$OMP END MASTER";
1421 case ST_OMP_END_ORDERED
:
1422 p
= "!$OMP END ORDERED";
1424 case ST_OMP_END_PARALLEL
:
1425 p
= "!$OMP END PARALLEL";
1427 case ST_OMP_END_PARALLEL_DO
:
1428 p
= "!$OMP END PARALLEL DO";
1430 case ST_OMP_END_PARALLEL_SECTIONS
:
1431 p
= "!$OMP END PARALLEL SECTIONS";
1433 case ST_OMP_END_PARALLEL_WORKSHARE
:
1434 p
= "!$OMP END PARALLEL WORKSHARE";
1436 case ST_OMP_END_SECTIONS
:
1437 p
= "!$OMP END SECTIONS";
1439 case ST_OMP_END_SINGLE
:
1440 p
= "!$OMP END SINGLE";
1442 case ST_OMP_END_TASK
:
1443 p
= "!$OMP END TASK";
1445 case ST_OMP_END_WORKSHARE
:
1446 p
= "!$OMP END WORKSHARE";
1454 case ST_OMP_ORDERED
:
1455 p
= "!$OMP ORDERED";
1457 case ST_OMP_PARALLEL
:
1458 p
= "!$OMP PARALLEL";
1460 case ST_OMP_PARALLEL_DO
:
1461 p
= "!$OMP PARALLEL DO";
1463 case ST_OMP_PARALLEL_SECTIONS
:
1464 p
= "!$OMP PARALLEL SECTIONS";
1466 case ST_OMP_PARALLEL_WORKSHARE
:
1467 p
= "!$OMP PARALLEL WORKSHARE";
1469 case ST_OMP_SECTIONS
:
1470 p
= "!$OMP SECTIONS";
1472 case ST_OMP_SECTION
:
1473 p
= "!$OMP SECTION";
1481 case ST_OMP_TASKWAIT
:
1482 p
= "!$OMP TASKWAIT";
1484 case ST_OMP_THREADPRIVATE
:
1485 p
= "!$OMP THREADPRIVATE";
1487 case ST_OMP_WORKSHARE
:
1488 p
= "!$OMP WORKSHARE";
1491 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1498 /* Create a symbol for the main program and assign it to ns->proc_name. */
1501 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1503 gfc_symbol
*main_program
;
1504 symbol_attribute attr
;
1506 gfc_get_symbol (name
, ns
, &main_program
);
1507 gfc_clear_attr (&attr
);
1508 attr
.flavor
= FL_PROGRAM
;
1509 attr
.proc
= PROC_UNKNOWN
;
1510 attr
.subroutine
= 1;
1511 attr
.access
= ACCESS_PUBLIC
;
1512 attr
.is_main_program
= 1;
1513 main_program
->attr
= attr
;
1514 main_program
->declared_at
= gfc_current_locus
;
1515 ns
->proc_name
= main_program
;
1516 gfc_commit_symbols ();
1520 /* Do whatever is necessary to accept the last statement. */
1523 accept_statement (gfc_statement st
)
1531 case ST_IMPLICIT_NONE
:
1532 gfc_set_implicit_none ();
1541 gfc_current_ns
->proc_name
= gfc_new_block
;
1544 /* If the statement is the end of a block, lay down a special code
1545 that allows a branch to the end of the block from within the
1546 construct. IF and SELECT are treated differently from DO
1547 (where EXEC_NOP is added inside the loop) for two
1549 1. END DO has a meaning in the sense that after a GOTO to
1550 it, the loop counter must be increased.
1551 2. IF blocks and SELECT blocks can consist of multiple
1552 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1553 Putting the label before the END IF would make the jump
1554 from, say, the ELSE IF block to the END IF illegal. */
1558 if (gfc_statement_label
!= NULL
)
1560 new_st
.op
= EXEC_END_BLOCK
;
1565 /* The end-of-program unit statements do not get the special
1566 marker and require a statement of some sort if they are a
1569 case ST_END_PROGRAM
:
1570 case ST_END_FUNCTION
:
1571 case ST_END_SUBROUTINE
:
1572 if (gfc_statement_label
!= NULL
)
1574 new_st
.op
= EXEC_RETURN
;
1579 new_st
.op
= EXEC_END_PROCEDURE
;
1595 gfc_commit_symbols ();
1596 gfc_warning_check ();
1597 gfc_clear_new_st ();
1601 /* Undo anything tentative that has been built for the current
1605 reject_statement (void)
1607 /* Revert to the previous charlen chain. */
1608 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
1609 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
1611 gfc_new_block
= NULL
;
1612 gfc_undo_symbols ();
1613 gfc_clear_warning ();
1614 undo_new_statement ();
1618 /* Generic complaint about an out of order statement. We also do
1619 whatever is necessary to clean up. */
1622 unexpected_statement (gfc_statement st
)
1624 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1626 reject_statement ();
1630 /* Given the next statement seen by the matcher, make sure that it is
1631 in proper order with the last. This subroutine is initialized by
1632 calling it with an argument of ST_NONE. If there is a problem, we
1633 issue an error and return FAILURE. Otherwise we return SUCCESS.
1635 Individual parsers need to verify that the statements seen are
1636 valid before calling here, i.e., ENTRY statements are not allowed in
1637 INTERFACE blocks. The following diagram is taken from the standard:
1639 +---------------------------------------+
1640 | program subroutine function module |
1641 +---------------------------------------+
1643 +---------------------------------------+
1645 +---------------------------------------+
1647 | +-----------+------------------+
1648 | | parameter | implicit |
1649 | +-----------+------------------+
1650 | format | | derived type |
1651 | entry | parameter | interface |
1652 | | data | specification |
1653 | | | statement func |
1654 | +-----------+------------------+
1655 | | data | executable |
1656 +--------+-----------+------------------+
1658 +---------------------------------------+
1659 | internal module/subprogram |
1660 +---------------------------------------+
1662 +---------------------------------------+
1671 ORDER_IMPLICIT_NONE
,
1679 enum state_order state
;
1680 gfc_statement last_statement
;
1686 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
1692 p
->state
= ORDER_START
;
1696 if (p
->state
> ORDER_USE
)
1698 p
->state
= ORDER_USE
;
1702 if (p
->state
> ORDER_IMPORT
)
1704 p
->state
= ORDER_IMPORT
;
1707 case ST_IMPLICIT_NONE
:
1708 if (p
->state
> ORDER_IMPLICIT_NONE
)
1711 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1712 statement disqualifies a USE but not an IMPLICIT NONE.
1713 Duplicate IMPLICIT NONEs are caught when the implicit types
1716 p
->state
= ORDER_IMPLICIT_NONE
;
1720 if (p
->state
> ORDER_IMPLICIT
)
1722 p
->state
= ORDER_IMPLICIT
;
1727 if (p
->state
< ORDER_IMPLICIT_NONE
)
1728 p
->state
= ORDER_IMPLICIT_NONE
;
1732 if (p
->state
>= ORDER_EXEC
)
1734 if (p
->state
< ORDER_IMPLICIT
)
1735 p
->state
= ORDER_IMPLICIT
;
1739 if (p
->state
< ORDER_SPEC
)
1740 p
->state
= ORDER_SPEC
;
1745 case ST_DERIVED_DECL
:
1747 if (p
->state
>= ORDER_EXEC
)
1749 if (p
->state
< ORDER_SPEC
)
1750 p
->state
= ORDER_SPEC
;
1755 if (p
->state
< ORDER_EXEC
)
1756 p
->state
= ORDER_EXEC
;
1760 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1761 gfc_ascii_statement (st
));
1764 /* All is well, record the statement in case we need it next time. */
1765 p
->where
= gfc_current_locus
;
1766 p
->last_statement
= st
;
1771 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1772 gfc_ascii_statement (st
),
1773 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1779 /* Handle an unexpected end of file. This is a show-stopper... */
1781 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1784 unexpected_eof (void)
1788 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1790 /* Memory cleanup. Move to "second to last". */
1791 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1794 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1797 longjmp (eof_buf
, 1);
1801 /* Parse the CONTAINS section of a derived type definition. */
1803 gfc_access gfc_typebound_default_access
;
1806 parse_derived_contains (void)
1809 bool seen_private
= false;
1810 bool seen_comps
= false;
1811 bool error_flag
= false;
1814 gcc_assert (gfc_current_state () == COMP_DERIVED
);
1815 gcc_assert (gfc_current_block ());
1817 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1819 if (gfc_current_block ()->attr
.sequence
)
1820 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1821 " section at %C", gfc_current_block ()->name
);
1822 if (gfc_current_block ()->attr
.is_bind_c
)
1823 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1824 " section at %C", gfc_current_block ()->name
);
1826 accept_statement (ST_CONTAINS
);
1827 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
1829 gfc_typebound_default_access
= ACCESS_PUBLIC
;
1835 st
= next_statement ();
1843 gfc_error ("Components in TYPE at %C must precede CONTAINS");
1848 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Type-bound"
1849 " procedure at %C") == FAILURE
)
1852 accept_statement (ST_PROCEDURE
);
1857 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: GENERIC binding"
1858 " at %C") == FAILURE
)
1861 accept_statement (ST_GENERIC
);
1866 if (gfc_notify_std (GFC_STD_F2003
,
1867 "Fortran 2003: FINAL procedure declaration"
1868 " at %C") == FAILURE
)
1871 accept_statement (ST_FINAL
);
1879 && (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Derived type "
1880 "definition at %C with empty CONTAINS "
1881 "section") == FAILURE
))
1884 /* ST_END_TYPE is accepted by parse_derived after return. */
1888 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1890 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1898 gfc_error ("PRIVATE statement at %C must precede procedure"
1906 gfc_error ("Duplicate PRIVATE statement at %C");
1910 accept_statement (ST_PRIVATE
);
1911 gfc_typebound_default_access
= ACCESS_PRIVATE
;
1912 seen_private
= true;
1916 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1921 gfc_error ("Already inside a CONTAINS block at %C");
1926 unexpected_statement (st
);
1932 gcc_assert (gfc_current_state () == COMP_DERIVED
);
1938 /* Parse a derived type. */
1941 parse_derived (void)
1943 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1951 accept_statement (ST_DERIVED_DECL
);
1952 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1954 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1961 while (compiling_type
)
1963 st
= next_statement ();
1971 accept_statement (st
);
1976 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
1985 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
1986 "definition at %C without components")
1990 accept_statement (ST_END_TYPE
);
1994 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1996 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2004 gfc_error ("PRIVATE statement at %C must precede "
2005 "structure components");
2012 gfc_error ("Duplicate PRIVATE statement at %C");
2016 s
.sym
->component_access
= ACCESS_PRIVATE
;
2018 accept_statement (ST_PRIVATE
);
2025 gfc_error ("SEQUENCE statement at %C must precede "
2026 "structure components");
2031 if (gfc_current_block ()->attr
.sequence
)
2032 gfc_warning ("SEQUENCE attribute at %C already specified in "
2037 gfc_error ("Duplicate SEQUENCE statement at %C");
2042 gfc_add_sequence (&gfc_current_block ()->attr
,
2043 gfc_current_block ()->name
, NULL
);
2047 if (gfc_notify_std (GFC_STD_F2003
,
2048 "Fortran 2003: CONTAINS block in derived type"
2049 " definition at %C") == FAILURE
)
2052 accept_statement (ST_CONTAINS
);
2053 if (parse_derived_contains ())
2058 unexpected_statement (st
);
2063 /* need to verify that all fields of the derived type are
2064 * interoperable with C if the type is declared to be bind(c)
2066 sym
= gfc_current_block ();
2067 for (c
= sym
->components
; c
; c
= c
->next
)
2069 /* Look for allocatable components. */
2070 if (c
->attr
.allocatable
2071 || (c
->ts
.type
== BT_CLASS
2072 && c
->ts
.u
.derived
->components
->attr
.allocatable
)
2073 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.alloc_comp
))
2074 sym
->attr
.alloc_comp
= 1;
2076 /* Look for pointer components. */
2078 || (c
->ts
.type
== BT_CLASS
2079 && c
->ts
.u
.derived
->components
->attr
.pointer
)
2080 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2081 sym
->attr
.pointer_comp
= 1;
2083 /* Look for procedure pointer components. */
2084 if (c
->attr
.proc_pointer
2085 || (c
->ts
.type
== BT_DERIVED
2086 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2087 sym
->attr
.proc_pointer_comp
= 1;
2089 /* Look for private components. */
2090 if (sym
->component_access
== ACCESS_PRIVATE
2091 || c
->attr
.access
== ACCESS_PRIVATE
2092 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2093 sym
->attr
.private_comp
= 1;
2096 if (!seen_component
)
2097 sym
->attr
.zero_comp
= 1;
2103 /* Parse an ENUM. */
2112 int seen_enumerator
= 0;
2116 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2120 while (compiling_enum
)
2122 st
= next_statement ();
2130 seen_enumerator
= 1;
2131 accept_statement (st
);
2136 if (!seen_enumerator
)
2138 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2141 accept_statement (st
);
2145 gfc_free_enum_history ();
2146 unexpected_statement (st
);
2154 /* Parse an interface. We must be able to deal with the possibility
2155 of recursive interfaces. The parse_spec() subroutine is mutually
2156 recursive with parse_interface(). */
2158 static gfc_statement
parse_spec (gfc_statement
);
2161 parse_interface (void)
2163 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2164 gfc_symbol
*prog_unit
, *sym
;
2165 gfc_interface_info save
;
2166 gfc_state_data s1
, s2
;
2170 accept_statement (ST_INTERFACE
);
2172 current_interface
.ns
= gfc_current_ns
;
2173 save
= current_interface
;
2175 sym
= (current_interface
.type
== INTERFACE_GENERIC
2176 || current_interface
.type
== INTERFACE_USER_OP
)
2177 ? gfc_new_block
: NULL
;
2179 push_state (&s1
, COMP_INTERFACE
, sym
);
2180 current_state
= COMP_NONE
;
2183 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2185 st
= next_statement ();
2193 if (st
== ST_SUBROUTINE
)
2194 new_state
= COMP_SUBROUTINE
;
2195 else if (st
== ST_FUNCTION
)
2196 new_state
= COMP_FUNCTION
;
2197 if (gfc_new_block
->attr
.pointer
)
2199 gfc_new_block
->attr
.pointer
= 0;
2200 gfc_new_block
->attr
.proc_pointer
= 1;
2202 if (gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2203 gfc_new_block
->formal
, NULL
) == FAILURE
)
2205 reject_statement ();
2206 gfc_free_namespace (gfc_current_ns
);
2212 case ST_MODULE_PROC
: /* The module procedure matcher makes
2213 sure the context is correct. */
2214 accept_statement (st
);
2215 gfc_free_namespace (gfc_current_ns
);
2218 case ST_END_INTERFACE
:
2219 gfc_free_namespace (gfc_current_ns
);
2220 gfc_current_ns
= current_interface
.ns
;
2224 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2225 gfc_ascii_statement (st
));
2226 reject_statement ();
2227 gfc_free_namespace (gfc_current_ns
);
2232 /* Make sure that a generic interface has only subroutines or
2233 functions and that the generic name has the right attribute. */
2234 if (current_interface
.type
== INTERFACE_GENERIC
)
2236 if (current_state
== COMP_NONE
)
2238 if (new_state
== COMP_FUNCTION
)
2239 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2240 else if (new_state
== COMP_SUBROUTINE
)
2241 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2243 current_state
= new_state
;
2247 if (new_state
!= current_state
)
2249 if (new_state
== COMP_SUBROUTINE
)
2250 gfc_error ("SUBROUTINE at %C does not belong in a "
2251 "generic function interface");
2253 if (new_state
== COMP_FUNCTION
)
2254 gfc_error ("FUNCTION at %C does not belong in a "
2255 "generic subroutine interface");
2260 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2262 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2263 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2264 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2265 "cannot be the same as an intrinsic type",
2266 gfc_new_block
->name
);
2269 push_state (&s2
, new_state
, gfc_new_block
);
2270 accept_statement (st
);
2271 prog_unit
= gfc_new_block
;
2272 prog_unit
->formal_ns
= gfc_current_ns
;
2273 proc_locus
= gfc_current_locus
;
2276 /* Read data declaration statements. */
2277 st
= parse_spec (ST_NONE
);
2279 /* Since the interface block does not permit an IMPLICIT statement,
2280 the default type for the function or the result must be taken
2281 from the formal namespace. */
2282 if (new_state
== COMP_FUNCTION
)
2284 if (prog_unit
->result
== prog_unit
2285 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2286 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2287 else if (prog_unit
->result
!= prog_unit
2288 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
2289 gfc_set_default_type (prog_unit
->result
, 1,
2290 prog_unit
->formal_ns
);
2293 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
2295 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2296 gfc_ascii_statement (st
));
2297 reject_statement ();
2301 /* Add EXTERNAL attribute to function or subroutine. */
2302 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
2303 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
2305 current_interface
= save
;
2306 gfc_add_interface (prog_unit
);
2309 if (current_interface
.ns
2310 && current_interface
.ns
->proc_name
2311 && strcmp (current_interface
.ns
->proc_name
->name
,
2312 prog_unit
->name
) == 0)
2313 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2314 "enclosing procedure", prog_unit
->name
, &proc_locus
);
2323 /* Associate function characteristics by going back to the function
2324 declaration and rematching the prefix. */
2327 match_deferred_characteristics (gfc_typespec
* ts
)
2330 match m
= MATCH_ERROR
;
2331 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2333 loc
= gfc_current_locus
;
2335 gfc_current_locus
= gfc_current_block ()->declared_at
;
2338 gfc_buffer_error (1);
2339 m
= gfc_match_prefix (ts
);
2340 gfc_buffer_error (0);
2342 if (ts
->type
== BT_DERIVED
)
2350 /* Only permit one go at the characteristic association. */
2354 /* Set the function locus correctly. If we have not found the
2355 function name, there is an error. */
2357 && gfc_match ("function% %n", name
) == MATCH_YES
2358 && strcmp (name
, gfc_current_block ()->name
) == 0)
2360 gfc_current_block ()->declared_at
= gfc_current_locus
;
2361 gfc_commit_symbols ();
2366 gfc_current_locus
=loc
;
2371 /* Check specification-expressions in the function result of the currently
2372 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2373 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2374 scope are not yet parsed so this has to be delayed up to parse_spec. */
2377 check_function_result_typed (void)
2379 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
2381 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
2382 gcc_assert (ts
->type
!= BT_UNKNOWN
);
2384 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2385 /* TODO: Extend when KIND type parameters are implemented. */
2386 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
2387 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
2391 /* Parse a set of specification statements. Returns the statement
2392 that doesn't fit. */
2394 static gfc_statement
2395 parse_spec (gfc_statement st
)
2398 bool function_result_typed
= false;
2399 bool bad_characteristic
= false;
2402 verify_st_order (&ss
, ST_NONE
, false);
2404 st
= next_statement ();
2406 /* If we are not inside a function or don't have a result specified so far,
2407 do nothing special about it. */
2408 if (gfc_current_state () != COMP_FUNCTION
)
2409 function_result_typed
= true;
2412 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
2415 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
2416 function_result_typed
= true;
2421 /* If we're inside a BLOCK construct, some statements are disallowed.
2422 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2423 or VALUE are also disallowed, but they don't have a particular ST_*
2424 key so we have to check for them individually in their matcher routine. */
2425 if (gfc_current_state () == COMP_BLOCK
)
2429 case ST_IMPLICIT_NONE
:
2432 case ST_EQUIVALENCE
:
2433 case ST_STATEMENT_FUNCTION
:
2434 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2435 gfc_ascii_statement (st
));
2442 /* If we find a statement that can not be followed by an IMPLICIT statement
2443 (and thus we can expect to see none any further), type the function result
2444 if it has not yet been typed. Be careful not to give the END statement
2445 to verify_st_order! */
2446 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
2448 bool verify_now
= false;
2450 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
2455 verify_st_order (&dummyss
, ST_NONE
, false);
2456 verify_st_order (&dummyss
, st
, false);
2458 if (verify_st_order (&dummyss
, ST_IMPLICIT
, true) == FAILURE
)
2464 check_function_result_typed ();
2465 function_result_typed
= true;
2474 case ST_IMPLICIT_NONE
:
2476 if (!function_result_typed
)
2478 check_function_result_typed ();
2479 function_result_typed
= true;
2485 case ST_DATA
: /* Not allowed in interfaces */
2486 if (gfc_current_state () == COMP_INTERFACE
)
2496 case ST_DERIVED_DECL
:
2499 if (verify_st_order (&ss
, st
, false) == FAILURE
)
2501 reject_statement ();
2502 st
= next_statement ();
2512 case ST_DERIVED_DECL
:
2518 if (gfc_current_state () != COMP_MODULE
)
2520 gfc_error ("%s statement must appear in a MODULE",
2521 gfc_ascii_statement (st
));
2525 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
2527 gfc_error ("%s statement at %C follows another accessibility "
2528 "specification", gfc_ascii_statement (st
));
2532 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
2533 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2537 case ST_STATEMENT_FUNCTION
:
2538 if (gfc_current_state () == COMP_MODULE
)
2540 unexpected_statement (st
);
2548 accept_statement (st
);
2549 st
= next_statement ();
2553 accept_statement (st
);
2555 st
= next_statement ();
2558 case ST_GET_FCN_CHARACTERISTICS
:
2559 /* This statement triggers the association of a function's result
2561 ts
= &gfc_current_block ()->result
->ts
;
2562 if (match_deferred_characteristics (ts
) != MATCH_YES
)
2563 bad_characteristic
= true;
2565 st
= next_statement ();
2572 /* If match_deferred_characteristics failed, then there is an error. */
2573 if (bad_characteristic
)
2575 ts
= &gfc_current_block ()->result
->ts
;
2576 if (ts
->type
!= BT_DERIVED
)
2577 gfc_error ("Bad kind expression for function '%s' at %L",
2578 gfc_current_block ()->name
,
2579 &gfc_current_block ()->declared_at
);
2581 gfc_error ("The type for function '%s' at %L is not accessible",
2582 gfc_current_block ()->name
,
2583 &gfc_current_block ()->declared_at
);
2585 gfc_current_block ()->ts
.kind
= 0;
2586 /* Keep the derived type; if it's bad, it will be discovered later. */
2587 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
2588 ts
->type
= BT_UNKNOWN
;
2595 /* Parse a WHERE block, (not a simple WHERE statement). */
2598 parse_where_block (void)
2600 int seen_empty_else
;
2605 accept_statement (ST_WHERE_BLOCK
);
2606 top
= gfc_state_stack
->tail
;
2608 push_state (&s
, COMP_WHERE
, gfc_new_block
);
2610 d
= add_statement ();
2611 d
->expr1
= top
->expr1
;
2617 seen_empty_else
= 0;
2621 st
= next_statement ();
2627 case ST_WHERE_BLOCK
:
2628 parse_where_block ();
2633 accept_statement (st
);
2637 if (seen_empty_else
)
2639 gfc_error ("ELSEWHERE statement at %C follows previous "
2640 "unmasked ELSEWHERE");
2644 if (new_st
.expr1
== NULL
)
2645 seen_empty_else
= 1;
2647 d
= new_level (gfc_state_stack
->head
);
2649 d
->expr1
= new_st
.expr1
;
2651 accept_statement (st
);
2656 accept_statement (st
);
2660 gfc_error ("Unexpected %s statement in WHERE block at %C",
2661 gfc_ascii_statement (st
));
2662 reject_statement ();
2666 while (st
!= ST_END_WHERE
);
2672 /* Parse a FORALL block (not a simple FORALL statement). */
2675 parse_forall_block (void)
2681 accept_statement (ST_FORALL_BLOCK
);
2682 top
= gfc_state_stack
->tail
;
2684 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2686 d
= add_statement ();
2687 d
->op
= EXEC_FORALL
;
2692 st
= next_statement ();
2697 case ST_POINTER_ASSIGNMENT
:
2700 accept_statement (st
);
2703 case ST_WHERE_BLOCK
:
2704 parse_where_block ();
2707 case ST_FORALL_BLOCK
:
2708 parse_forall_block ();
2712 accept_statement (st
);
2719 gfc_error ("Unexpected %s statement in FORALL block at %C",
2720 gfc_ascii_statement (st
));
2722 reject_statement ();
2726 while (st
!= ST_END_FORALL
);
2732 static gfc_statement
parse_executable (gfc_statement
);
2734 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2737 parse_if_block (void)
2746 accept_statement (ST_IF_BLOCK
);
2748 top
= gfc_state_stack
->tail
;
2749 push_state (&s
, COMP_IF
, gfc_new_block
);
2751 new_st
.op
= EXEC_IF
;
2752 d
= add_statement ();
2754 d
->expr1
= top
->expr1
;
2760 st
= parse_executable (ST_NONE
);
2770 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2771 "statement at %L", &else_locus
);
2773 reject_statement ();
2777 d
= new_level (gfc_state_stack
->head
);
2779 d
->expr1
= new_st
.expr1
;
2781 accept_statement (st
);
2788 gfc_error ("Duplicate ELSE statements at %L and %C",
2790 reject_statement ();
2795 else_locus
= gfc_current_locus
;
2797 d
= new_level (gfc_state_stack
->head
);
2800 accept_statement (st
);
2808 unexpected_statement (st
);
2812 while (st
!= ST_ENDIF
);
2815 accept_statement (st
);
2819 /* Parse a SELECT block. */
2822 parse_select_block (void)
2828 accept_statement (ST_SELECT_CASE
);
2830 cp
= gfc_state_stack
->tail
;
2831 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2833 /* Make sure that the next statement is a CASE or END SELECT. */
2836 st
= next_statement ();
2839 if (st
== ST_END_SELECT
)
2841 /* Empty SELECT CASE is OK. */
2842 accept_statement (st
);
2849 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2852 reject_statement ();
2855 /* At this point, we're got a nonempty select block. */
2856 cp
= new_level (cp
);
2859 accept_statement (st
);
2863 st
= parse_executable (ST_NONE
);
2870 cp
= new_level (gfc_state_stack
->head
);
2872 gfc_clear_new_st ();
2874 accept_statement (st
);
2880 /* Can't have an executable statement because of
2881 parse_executable(). */
2883 unexpected_statement (st
);
2887 while (st
!= ST_END_SELECT
);
2890 accept_statement (st
);
2894 /* Pop the current selector from the SELECT TYPE stack. */
2897 select_type_pop (void)
2899 gfc_select_type_stack
*old
= select_type_stack
;
2900 select_type_stack
= old
->prev
;
2905 /* Parse a SELECT TYPE construct (F03:R821). */
2908 parse_select_type_block (void)
2914 accept_statement (ST_SELECT_TYPE
);
2916 cp
= gfc_state_stack
->tail
;
2917 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
2919 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2923 st
= next_statement ();
2926 if (st
== ST_END_SELECT
)
2927 /* Empty SELECT CASE is OK. */
2929 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
2932 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2933 "following SELECT TYPE at %C");
2935 reject_statement ();
2938 /* At this point, we're got a nonempty select block. */
2939 cp
= new_level (cp
);
2942 accept_statement (st
);
2946 st
= parse_executable (ST_NONE
);
2954 cp
= new_level (gfc_state_stack
->head
);
2956 gfc_clear_new_st ();
2958 accept_statement (st
);
2964 /* Can't have an executable statement because of
2965 parse_executable(). */
2967 unexpected_statement (st
);
2971 while (st
!= ST_END_SELECT
);
2975 accept_statement (st
);
2976 gfc_current_ns
= gfc_current_ns
->parent
;
2981 /* Given a symbol, make sure it is not an iteration variable for a DO
2982 statement. This subroutine is called when the symbol is seen in a
2983 context that causes it to become redefined. If the symbol is an
2984 iterator, we generate an error message and return nonzero. */
2987 gfc_check_do_variable (gfc_symtree
*st
)
2991 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2992 if (s
->do_variable
== st
)
2994 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2995 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3003 /* Checks to see if the current statement label closes an enddo.
3004 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3005 an error) if it incorrectly closes an ENDDO. */
3008 check_do_closure (void)
3012 if (gfc_statement_label
== NULL
)
3015 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3016 if (p
->state
== COMP_DO
)
3020 return 0; /* No loops to close */
3022 if (p
->ext
.end_do_label
== gfc_statement_label
)
3024 if (p
== gfc_state_stack
)
3027 gfc_error ("End of nonblock DO statement at %C is within another block");
3031 /* At this point, the label doesn't terminate the innermost loop.
3032 Make sure it doesn't terminate another one. */
3033 for (; p
; p
= p
->previous
)
3034 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
3036 gfc_error ("End of nonblock DO statement at %C is interwoven "
3037 "with another DO loop");
3045 /* Parse a series of contained program units. */
3047 static void parse_progunit (gfc_statement
);
3050 /* Set up the local namespace for a BLOCK construct. */
3053 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3055 gfc_namespace
* my_ns
;
3057 my_ns
= gfc_get_namespace (parent_ns
, 1);
3058 my_ns
->construct_entities
= 1;
3060 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3061 code generation (so it must not be NULL).
3062 We set its recursive argument if our container procedure is recursive, so
3063 that local variables are accordingly placed on the stack when it
3064 will be necessary. */
3066 my_ns
->proc_name
= gfc_new_block
;
3071 gfc_get_symbol ("block@", my_ns
, &my_ns
->proc_name
);
3072 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3073 my_ns
->proc_name
->name
, NULL
);
3074 gcc_assert (t
== SUCCESS
);
3077 if (parent_ns
->proc_name
)
3078 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3084 /* Parse a BLOCK construct. */
3087 parse_block_construct (void)
3089 gfc_namespace
* my_ns
;
3092 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: BLOCK construct at %C");
3094 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3096 new_st
.op
= EXEC_BLOCK
;
3097 new_st
.ext
.ns
= my_ns
;
3098 accept_statement (ST_BLOCK
);
3100 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3101 gfc_current_ns
= my_ns
;
3103 parse_progunit (ST_NONE
);
3105 gfc_current_ns
= gfc_current_ns
->parent
;
3110 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3111 handled inside of parse_executable(), because they aren't really
3115 parse_do_block (void)
3122 s
.ext
.end_do_label
= new_st
.label1
;
3124 if (new_st
.ext
.iterator
!= NULL
)
3125 stree
= new_st
.ext
.iterator
->var
->symtree
;
3129 accept_statement (ST_DO
);
3131 top
= gfc_state_stack
->tail
;
3132 push_state (&s
, COMP_DO
, gfc_new_block
);
3134 s
.do_variable
= stree
;
3136 top
->block
= new_level (top
);
3137 top
->block
->op
= EXEC_DO
;
3140 st
= parse_executable (ST_NONE
);
3148 if (s
.ext
.end_do_label
!= NULL
3149 && s
.ext
.end_do_label
!= gfc_statement_label
)
3150 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3153 if (gfc_statement_label
!= NULL
)
3155 new_st
.op
= EXEC_NOP
;
3160 case ST_IMPLIED_ENDDO
:
3161 /* If the do-stmt of this DO construct has a do-construct-name,
3162 the corresponding end-do must be an end-do-stmt (with a matching
3163 name, but in that case we must have seen ST_ENDDO first).
3164 We only complain about this in pedantic mode. */
3165 if (gfc_current_block () != NULL
)
3166 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3167 &gfc_current_block()->declared_at
);
3172 unexpected_statement (st
);
3177 accept_statement (st
);
3181 /* Parse the statements of OpenMP do/parallel do. */
3183 static gfc_statement
3184 parse_omp_do (gfc_statement omp_st
)
3190 accept_statement (omp_st
);
3192 cp
= gfc_state_stack
->tail
;
3193 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3194 np
= new_level (cp
);
3200 st
= next_statement ();
3203 else if (st
== ST_DO
)
3206 unexpected_statement (st
);
3210 if (gfc_statement_label
!= NULL
3211 && gfc_state_stack
->previous
!= NULL
3212 && gfc_state_stack
->previous
->state
== COMP_DO
3213 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
3221 there should be no !$OMP END DO. */
3223 return ST_IMPLIED_ENDDO
;
3226 check_do_closure ();
3229 st
= next_statement ();
3230 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
3232 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
3233 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3235 gcc_assert (new_st
.op
== EXEC_NOP
);
3236 gfc_clear_new_st ();
3237 gfc_commit_symbols ();
3238 gfc_warning_check ();
3239 st
= next_statement ();
3245 /* Parse the statements of OpenMP atomic directive. */
3248 parse_omp_atomic (void)
3254 accept_statement (ST_OMP_ATOMIC
);
3256 cp
= gfc_state_stack
->tail
;
3257 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3258 np
= new_level (cp
);
3264 st
= next_statement ();
3267 else if (st
== ST_ASSIGNMENT
)
3270 unexpected_statement (st
);
3273 accept_statement (st
);
3279 /* Parse the statements of an OpenMP structured block. */
3282 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
3284 gfc_statement st
, omp_end_st
;
3288 accept_statement (omp_st
);
3290 cp
= gfc_state_stack
->tail
;
3291 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3292 np
= new_level (cp
);
3298 case ST_OMP_PARALLEL
:
3299 omp_end_st
= ST_OMP_END_PARALLEL
;
3301 case ST_OMP_PARALLEL_SECTIONS
:
3302 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
3304 case ST_OMP_SECTIONS
:
3305 omp_end_st
= ST_OMP_END_SECTIONS
;
3307 case ST_OMP_ORDERED
:
3308 omp_end_st
= ST_OMP_END_ORDERED
;
3310 case ST_OMP_CRITICAL
:
3311 omp_end_st
= ST_OMP_END_CRITICAL
;
3314 omp_end_st
= ST_OMP_END_MASTER
;
3317 omp_end_st
= ST_OMP_END_SINGLE
;
3320 omp_end_st
= ST_OMP_END_TASK
;
3322 case ST_OMP_WORKSHARE
:
3323 omp_end_st
= ST_OMP_END_WORKSHARE
;
3325 case ST_OMP_PARALLEL_WORKSHARE
:
3326 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
3334 if (workshare_stmts_only
)
3336 /* Inside of !$omp workshare, only
3339 where statements and constructs
3340 forall statements and constructs
3344 are allowed. For !$omp critical these
3345 restrictions apply recursively. */
3348 st
= next_statement ();
3359 accept_statement (st
);
3362 case ST_WHERE_BLOCK
:
3363 parse_where_block ();
3366 case ST_FORALL_BLOCK
:
3367 parse_forall_block ();
3370 case ST_OMP_PARALLEL
:
3371 case ST_OMP_PARALLEL_SECTIONS
:
3372 parse_omp_structured_block (st
, false);
3375 case ST_OMP_PARALLEL_WORKSHARE
:
3376 case ST_OMP_CRITICAL
:
3377 parse_omp_structured_block (st
, true);
3380 case ST_OMP_PARALLEL_DO
:
3381 st
= parse_omp_do (st
);
3385 parse_omp_atomic ();
3396 st
= next_statement ();
3400 st
= parse_executable (ST_NONE
);
3403 else if (st
== ST_OMP_SECTION
3404 && (omp_st
== ST_OMP_SECTIONS
3405 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
3407 np
= new_level (np
);
3411 else if (st
!= omp_end_st
)
3412 unexpected_statement (st
);
3414 while (st
!= omp_end_st
);
3418 case EXEC_OMP_END_NOWAIT
:
3419 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3421 case EXEC_OMP_CRITICAL
:
3422 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
3423 || (new_st
.ext
.omp_name
!= NULL
3424 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
3425 gfc_error ("Name after !$omp critical and !$omp end critical does "
3427 gfc_free (CONST_CAST (char *, new_st
.ext
.omp_name
));
3429 case EXEC_OMP_END_SINGLE
:
3430 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
3431 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
3432 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
3433 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
3441 gfc_clear_new_st ();
3442 gfc_commit_symbols ();
3443 gfc_warning_check ();
3448 /* Accept a series of executable statements. We return the first
3449 statement that doesn't fit to the caller. Any block statements are
3450 passed on to the correct handler, which usually passes the buck
3453 static gfc_statement
3454 parse_executable (gfc_statement st
)
3459 st
= next_statement ();
3463 close_flag
= check_do_closure ();
3468 case ST_END_PROGRAM
:
3471 case ST_END_FUNCTION
:
3475 case ST_END_SUBROUTINE
:
3480 case ST_SELECT_CASE
:
3481 gfc_error ("%s statement at %C cannot terminate a non-block "
3482 "DO loop", gfc_ascii_statement (st
));
3498 accept_statement (st
);
3499 if (close_flag
== 1)
3500 return ST_IMPLIED_ENDDO
;
3504 parse_block_construct ();
3511 case ST_SELECT_CASE
:
3512 parse_select_block ();
3515 case ST_SELECT_TYPE
:
3516 parse_select_type_block();
3521 if (check_do_closure () == 1)
3522 return ST_IMPLIED_ENDDO
;
3525 case ST_WHERE_BLOCK
:
3526 parse_where_block ();
3529 case ST_FORALL_BLOCK
:
3530 parse_forall_block ();
3533 case ST_OMP_PARALLEL
:
3534 case ST_OMP_PARALLEL_SECTIONS
:
3535 case ST_OMP_SECTIONS
:
3536 case ST_OMP_ORDERED
:
3537 case ST_OMP_CRITICAL
:
3541 parse_omp_structured_block (st
, false);
3544 case ST_OMP_WORKSHARE
:
3545 case ST_OMP_PARALLEL_WORKSHARE
:
3546 parse_omp_structured_block (st
, true);
3550 case ST_OMP_PARALLEL_DO
:
3551 st
= parse_omp_do (st
);
3552 if (st
== ST_IMPLIED_ENDDO
)
3557 parse_omp_atomic ();
3564 st
= next_statement ();
3569 /* Fix the symbols for sibling functions. These are incorrectly added to
3570 the child namespace as the parser didn't know about this procedure. */
3573 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
3577 gfc_symbol
*old_sym
;
3579 sym
->attr
.referenced
= 1;
3580 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
3582 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
3584 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
3585 goto fixup_contained
;
3587 old_sym
= st
->n
.sym
;
3588 if (old_sym
->ns
== ns
3589 && !old_sym
->attr
.contained
3591 /* By 14.6.1.3, host association should be excluded
3592 for the following. */
3593 && !(old_sym
->attr
.external
3594 || (old_sym
->ts
.type
!= BT_UNKNOWN
3595 && !old_sym
->attr
.implicit_type
)
3596 || old_sym
->attr
.flavor
== FL_PARAMETER
3597 || old_sym
->attr
.in_common
3598 || old_sym
->attr
.in_equivalence
3599 || old_sym
->attr
.data
3600 || old_sym
->attr
.dummy
3601 || old_sym
->attr
.result
3602 || old_sym
->attr
.dimension
3603 || old_sym
->attr
.allocatable
3604 || old_sym
->attr
.intrinsic
3605 || old_sym
->attr
.generic
3606 || old_sym
->attr
.flavor
== FL_NAMELIST
3607 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
3609 /* Replace it with the symbol from the parent namespace. */
3613 /* Free the old (local) symbol. */
3615 if (old_sym
->refs
== 0)
3616 gfc_free_symbol (old_sym
);
3620 /* Do the same for any contained procedures. */
3621 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
3626 parse_contained (int module
)
3628 gfc_namespace
*ns
, *parent_ns
, *tmp
;
3629 gfc_state_data s1
, s2
;
3633 int contains_statements
= 0;
3636 push_state (&s1
, COMP_CONTAINS
, NULL
);
3637 parent_ns
= gfc_current_ns
;
3641 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
3643 gfc_current_ns
->sibling
= parent_ns
->contained
;
3644 parent_ns
->contained
= gfc_current_ns
;
3647 /* Process the next available statement. We come here if we got an error
3648 and rejected the last statement. */
3649 st
= next_statement ();
3658 contains_statements
= 1;
3659 accept_statement (st
);
3662 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
3665 /* For internal procedures, create/update the symbol in the
3666 parent namespace. */
3670 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
3671 gfc_error ("Contained procedure '%s' at %C is already "
3672 "ambiguous", gfc_new_block
->name
);
3675 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
3676 &gfc_new_block
->declared_at
) ==
3679 if (st
== ST_FUNCTION
)
3680 gfc_add_function (&sym
->attr
, sym
->name
,
3681 &gfc_new_block
->declared_at
);
3683 gfc_add_subroutine (&sym
->attr
, sym
->name
,
3684 &gfc_new_block
->declared_at
);
3688 gfc_commit_symbols ();
3691 sym
= gfc_new_block
;
3693 /* Mark this as a contained function, so it isn't replaced
3694 by other module functions. */
3695 sym
->attr
.contained
= 1;
3696 sym
->attr
.referenced
= 1;
3698 parse_progunit (ST_NONE
);
3700 /* Fix up any sibling functions that refer to this one. */
3701 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
3702 /* Or refer to any of its alternate entry points. */
3703 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
3704 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
3706 gfc_current_ns
->code
= s2
.head
;
3707 gfc_current_ns
= parent_ns
;
3712 /* These statements are associated with the end of the host unit. */
3713 case ST_END_FUNCTION
:
3715 case ST_END_PROGRAM
:
3716 case ST_END_SUBROUTINE
:
3717 accept_statement (st
);
3721 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3722 gfc_ascii_statement (st
));
3723 reject_statement ();
3729 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
3730 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
3732 /* The first namespace in the list is guaranteed to not have
3733 anything (worthwhile) in it. */
3734 tmp
= gfc_current_ns
;
3735 gfc_current_ns
= parent_ns
;
3736 if (seen_error
&& tmp
->refs
> 1)
3737 gfc_free_namespace (tmp
);
3739 ns
= gfc_current_ns
->contained
;
3740 gfc_current_ns
->contained
= ns
->sibling
;
3741 gfc_free_namespace (ns
);
3744 if (!contains_statements
)
3745 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: CONTAINS statement without "
3746 "FUNCTION or SUBROUTINE statement at %C");
3750 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
3753 parse_progunit (gfc_statement st
)
3758 st
= parse_spec (st
);
3765 /* This is not allowed within BLOCK! */
3766 if (gfc_current_state () != COMP_BLOCK
)
3771 accept_statement (st
);
3778 if (gfc_current_state () == COMP_FUNCTION
)
3779 gfc_check_function_type (gfc_current_ns
);
3784 st
= parse_executable (st
);
3792 /* This is not allowed within BLOCK! */
3793 if (gfc_current_state () != COMP_BLOCK
)
3798 accept_statement (st
);
3805 unexpected_statement (st
);
3806 reject_statement ();
3807 st
= next_statement ();
3813 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3814 if (p
->state
== COMP_CONTAINS
)
3817 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
3822 gfc_error ("CONTAINS statement at %C is already in a contained "
3824 st
= next_statement ();
3828 parse_contained (0);
3831 gfc_current_ns
->code
= gfc_state_stack
->head
;
3835 /* Come here to complain about a global symbol already in use as
3839 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
3844 where
= &gfc_current_locus
;
3854 case GSYM_SUBROUTINE
:
3855 name
= "SUBROUTINE";
3860 case GSYM_BLOCK_DATA
:
3861 name
= "BLOCK DATA";
3867 gfc_internal_error ("gfc_global_used(): Bad type");
3871 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3872 sym
->name
, where
, name
, &sym
->where
);
3876 /* Parse a block data program unit. */
3879 parse_block_data (void)
3882 static locus blank_locus
;
3883 static int blank_block
=0;
3886 gfc_current_ns
->proc_name
= gfc_new_block
;
3887 gfc_current_ns
->is_block_data
= 1;
3889 if (gfc_new_block
== NULL
)
3892 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3893 "prior BLOCK DATA at %L", &blank_locus
);
3897 blank_locus
= gfc_current_locus
;
3902 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3904 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3905 gfc_global_used(s
, NULL
);
3908 s
->type
= GSYM_BLOCK_DATA
;
3909 s
->where
= gfc_current_locus
;
3914 st
= parse_spec (ST_NONE
);
3916 while (st
!= ST_END_BLOCK_DATA
)
3918 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3919 gfc_ascii_statement (st
));
3920 reject_statement ();
3921 st
= next_statement ();
3926 /* Parse a module subprogram. */
3934 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3935 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3936 gfc_global_used(s
, NULL
);
3939 s
->type
= GSYM_MODULE
;
3940 s
->where
= gfc_current_locus
;
3944 st
= parse_spec (ST_NONE
);
3953 parse_contained (1);
3957 accept_statement (st
);
3961 gfc_error ("Unexpected %s statement in MODULE at %C",
3962 gfc_ascii_statement (st
));
3964 reject_statement ();
3965 st
= next_statement ();
3969 s
->ns
= gfc_current_ns
;
3973 /* Add a procedure name to the global symbol table. */
3976 add_global_procedure (int sub
)
3980 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3983 || (s
->type
!= GSYM_UNKNOWN
3984 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3985 gfc_global_used(s
, NULL
);
3988 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3989 s
->where
= gfc_current_locus
;
3991 s
->ns
= gfc_current_ns
;
3996 /* Add a program to the global symbol table. */
3999 add_global_program (void)
4003 if (gfc_new_block
== NULL
)
4005 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4007 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
4008 gfc_global_used(s
, NULL
);
4011 s
->type
= GSYM_PROGRAM
;
4012 s
->where
= gfc_current_locus
;
4014 s
->ns
= gfc_current_ns
;
4019 /* Resolve all the program units when whole file scope option
4022 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4024 gfc_free_dt_list ();
4025 gfc_current_ns
= gfc_global_ns_list
;
4026 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4028 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4029 gfc_resolve (gfc_current_ns
);
4030 gfc_current_ns
->derived_types
= gfc_derived_types
;
4031 gfc_derived_types
= NULL
;
4037 clean_up_modules (gfc_gsymbol
*gsym
)
4042 clean_up_modules (gsym
->left
);
4043 clean_up_modules (gsym
->right
);
4045 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
4048 gfc_current_ns
= gsym
->ns
;
4049 gfc_derived_types
= gfc_current_ns
->derived_types
;
4056 /* Translate all the program units when whole file scope option
4057 is active. This could be in a different order to resolution if
4058 there are forward references in the file. */
4060 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4064 gfc_current_ns
= gfc_global_ns_list
;
4065 gfc_get_errors (NULL
, &errors
);
4067 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4069 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4070 gfc_derived_types
= gfc_current_ns
->derived_types
;
4071 gfc_generate_code (gfc_current_ns
);
4072 gfc_current_ns
->translated
= 1;
4075 /* Clean up all the namespaces after translation. */
4076 gfc_current_ns
= gfc_global_ns_list
;
4077 for (;gfc_current_ns
;)
4079 gfc_namespace
*ns
= gfc_current_ns
->sibling
;
4080 gfc_derived_types
= gfc_current_ns
->derived_types
;
4082 gfc_current_ns
= ns
;
4085 clean_up_modules (gfc_gsym_root
);
4089 /* Top level parser. */
4092 gfc_parse_file (void)
4094 int seen_program
, errors_before
, errors
;
4095 gfc_state_data top
, s
;
4098 gfc_namespace
*next
;
4100 gfc_start_source_files ();
4102 top
.state
= COMP_NONE
;
4104 top
.previous
= NULL
;
4105 top
.head
= top
.tail
= NULL
;
4106 top
.do_variable
= NULL
;
4108 gfc_state_stack
= &top
;
4110 gfc_clear_new_st ();
4112 gfc_statement_label
= NULL
;
4114 if (setjmp (eof_buf
))
4115 return FAILURE
; /* Come here on unexpected EOF */
4117 /* Prepare the global namespace that will contain the
4119 gfc_global_ns_list
= next
= NULL
;
4123 /* Exit early for empty files. */
4129 st
= next_statement ();
4138 goto duplicate_main
;
4140 prog_locus
= gfc_current_locus
;
4142 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4143 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
4144 accept_statement (st
);
4145 add_global_program ();
4146 parse_progunit (ST_NONE
);
4147 if (gfc_option
.flag_whole_file
)
4152 add_global_procedure (1);
4153 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
4154 accept_statement (st
);
4155 parse_progunit (ST_NONE
);
4156 if (gfc_option
.flag_whole_file
)
4161 add_global_procedure (0);
4162 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
4163 accept_statement (st
);
4164 parse_progunit (ST_NONE
);
4165 if (gfc_option
.flag_whole_file
)
4170 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
4171 accept_statement (st
);
4172 parse_block_data ();
4176 push_state (&s
, COMP_MODULE
, gfc_new_block
);
4177 accept_statement (st
);
4179 gfc_get_errors (NULL
, &errors_before
);
4183 /* Anything else starts a nameless main program block. */
4186 goto duplicate_main
;
4188 prog_locus
= gfc_current_locus
;
4190 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4191 main_program_symbol (gfc_current_ns
, "MAIN__");
4192 parse_progunit (st
);
4193 if (gfc_option
.flag_whole_file
)
4198 /* Handle the non-program units. */
4199 gfc_current_ns
->code
= s
.head
;
4201 gfc_resolve (gfc_current_ns
);
4203 /* Dump the parse tree if requested. */
4204 if (gfc_option
.dump_parse_tree
)
4205 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4207 gfc_get_errors (NULL
, &errors
);
4208 if (s
.state
== COMP_MODULE
)
4210 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
4212 gfc_generate_module_code (gfc_current_ns
);
4214 if (!gfc_option
.flag_whole_file
)
4218 gfc_current_ns
->derived_types
= gfc_derived_types
;
4219 gfc_derived_types
= NULL
;
4220 gfc_current_ns
= NULL
;
4226 gfc_generate_code (gfc_current_ns
);
4234 /* The main program and non-contained procedures are put
4235 in the global namespace list, so that they can be processed
4236 later and all their interfaces resolved. */
4237 gfc_current_ns
->code
= s
.head
;
4239 next
->sibling
= gfc_current_ns
;
4241 gfc_global_ns_list
= gfc_current_ns
;
4243 next
= gfc_current_ns
;
4250 if (!gfc_option
.flag_whole_file
)
4253 /* Do the resolution. */
4254 resolve_all_program_units (gfc_global_ns_list
);
4256 /* Do the parse tree dump. */
4258 = gfc_option
.dump_parse_tree
? gfc_global_ns_list
: NULL
;
4260 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4262 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4263 fputs ("------------------------------------------\n\n", stdout
);
4266 /* Do the translation. */
4267 translate_all_program_units (gfc_global_ns_list
);
4271 gfc_end_source_files ();
4275 /* If we see a duplicate main program, shut down. If the second
4276 instance is an implied main program, i.e. data decls or executable
4277 statements, we're in for lots of errors. */
4278 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
4279 reject_statement ();