2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* Current statement label. Zero means no statement label. Because new_st
31 can get wiped during statement matching, we have to keep it separate. */
33 gfc_st_label
*gfc_statement_label
;
35 static locus label_locus
;
36 static jmp_buf eof_buf
;
38 gfc_state_data
*gfc_state_stack
;
40 /* TODO: Re-order functions to kill these forward decls. */
41 static void check_statement_label (gfc_statement
);
42 static void undo_new_statement (void);
43 static void reject_statement (void);
45 /* A sort of half-matching function. We try to match the word on the
46 input with the passed string. If this succeeds, we call the
47 keyword-dependent matching function that will match the rest of the
48 statement. For single keywords, the matching subroutine is
52 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
67 gfc_current_locus
= *old_locus
;
75 /* Figure out what the next statement is, (mostly) regardless of
76 proper ordering. The do...while(0) is there to prevent if/else
79 #define match(keyword, subr, st) \
81 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
84 undo_new_statement (); \
88 decode_statement (void)
99 gfc_clear_error (); /* Clear any pending errors. */
100 gfc_clear_warning (); /* Clear any pending warnings. */
102 if (gfc_match_eos () == MATCH_YES
)
105 old_locus
= gfc_current_locus
;
107 /* Try matching a data declaration or function declaration. The
108 input "REALFUNCTIONA(N)" can mean several things in different
109 contexts, so it (and its relatives) get special treatment. */
111 if (gfc_current_state () == COMP_NONE
112 || gfc_current_state () == COMP_INTERFACE
113 || gfc_current_state () == COMP_CONTAINS
)
115 m
= gfc_match_function_decl ();
118 else if (m
== MATCH_ERROR
)
122 gfc_current_locus
= old_locus
;
125 /* Match statements whose error messages are meant to be overwritten
126 by something better. */
128 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
129 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
130 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
132 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
133 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
135 /* Try to match a subroutine statement, which has the same optional
136 prefixes that functions can have. */
138 if (gfc_match_subroutine () == MATCH_YES
)
139 return ST_SUBROUTINE
;
141 gfc_current_locus
= old_locus
;
143 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
144 might begin with a block label. The match functions for these
145 statements are unusual in that their keyword is not seen before
146 the matcher is called. */
148 if (gfc_match_if (&st
) == MATCH_YES
)
151 gfc_current_locus
= old_locus
;
153 if (gfc_match_where (&st
) == MATCH_YES
)
156 gfc_current_locus
= old_locus
;
158 if (gfc_match_forall (&st
) == MATCH_YES
)
161 gfc_current_locus
= old_locus
;
163 match (NULL
, gfc_match_do
, ST_DO
);
164 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
166 /* General statement matching: Instead of testing every possible
167 statement, we eliminate most possibilities by peeking at the
170 c
= gfc_peek_char ();
175 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
176 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
177 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
181 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
182 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
186 match ("call", gfc_match_call
, ST_CALL
);
187 match ("close", gfc_match_close
, ST_CLOSE
);
188 match ("continue", gfc_match_continue
, ST_CONTINUE
);
189 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
190 match ("case", gfc_match_case
, ST_CASE
);
191 match ("common", gfc_match_common
, ST_COMMON
);
192 match ("contains", gfc_match_eos
, ST_CONTAINS
);
196 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
197 match ("data", gfc_match_data
, ST_DATA
);
198 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
202 match ("end file", gfc_match_endfile
, ST_END_FILE
);
203 match ("exit", gfc_match_exit
, ST_EXIT
);
204 match ("else", gfc_match_else
, ST_ELSE
);
205 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
206 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
207 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
209 if (gfc_match_end (&st
) == MATCH_YES
)
212 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
213 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
214 match ("external", gfc_match_external
, ST_ATTR_DECL
);
218 match ("flush", gfc_match_flush
, ST_FLUSH
);
219 match ("format", gfc_match_format
, ST_FORMAT
);
223 match ("go to", gfc_match_goto
, ST_GOTO
);
227 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
228 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
229 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
230 match ("import", gfc_match_import
, ST_IMPORT
);
231 match ("interface", gfc_match_interface
, ST_INTERFACE
);
232 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
233 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
237 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
238 match ("module", gfc_match_module
, ST_MODULE
);
242 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
243 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
247 match ("open", gfc_match_open
, ST_OPEN
);
248 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
252 match ("print", gfc_match_print
, ST_WRITE
);
253 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
254 match ("pause", gfc_match_pause
, ST_PAUSE
);
255 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
256 if (gfc_match_private (&st
) == MATCH_YES
)
258 match ("program", gfc_match_program
, ST_PROGRAM
);
259 if (gfc_match_public (&st
) == MATCH_YES
)
261 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
265 match ("read", gfc_match_read
, ST_READ
);
266 match ("return", gfc_match_return
, ST_RETURN
);
267 match ("rewind", gfc_match_rewind
, ST_REWIND
);
271 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
272 match ("stop", gfc_match_stop
, ST_STOP
);
273 match ("save", gfc_match_save
, ST_ATTR_DECL
);
277 match ("target", gfc_match_target
, ST_ATTR_DECL
);
278 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
282 match ("use", gfc_match_use
, ST_USE
);
286 match ("value", gfc_match_value
, ST_ATTR_DECL
);
287 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
291 match ("write", gfc_match_write
, ST_WRITE
);
295 /* All else has failed, so give up. See if any of the matchers has
296 stored an error message of some sort. */
298 if (gfc_error_check () == 0)
299 gfc_error_now ("Unclassifiable statement at %C");
303 gfc_error_recovery ();
309 decode_omp_directive (void)
318 gfc_clear_error (); /* Clear any pending errors. */
319 gfc_clear_warning (); /* Clear any pending warnings. */
323 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
324 "or ELEMENTAL procedures");
325 gfc_error_recovery ();
329 old_locus
= gfc_current_locus
;
331 /* General OpenMP directive matching: Instead of testing every possible
332 statement, we eliminate most possibilities by peeking at the
335 c
= gfc_peek_char ();
340 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
343 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
346 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
349 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
352 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
353 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
354 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
355 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
356 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
357 match ("end parallel sections", gfc_match_omp_eos
,
358 ST_OMP_END_PARALLEL_SECTIONS
);
359 match ("end parallel workshare", gfc_match_omp_eos
,
360 ST_OMP_END_PARALLEL_WORKSHARE
);
361 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
362 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
363 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
364 match ("end workshare", gfc_match_omp_end_nowait
,
365 ST_OMP_END_WORKSHARE
);
368 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
371 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
374 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
377 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
378 match ("parallel sections", gfc_match_omp_parallel_sections
,
379 ST_OMP_PARALLEL_SECTIONS
);
380 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
381 ST_OMP_PARALLEL_WORKSHARE
);
382 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
385 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
386 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
387 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
390 match ("threadprivate", gfc_match_omp_threadprivate
,
391 ST_OMP_THREADPRIVATE
);
393 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
397 /* All else has failed, so give up. See if any of the matchers has
398 stored an error message of some sort. */
400 if (gfc_error_check () == 0)
401 gfc_error_now ("Unclassifiable OpenMP directive at %C");
405 gfc_error_recovery ();
413 /* Get the next statement in free form source. */
419 int c
, d
, cnt
, at_bol
;
421 at_bol
= gfc_at_bol ();
422 gfc_gobble_whitespace ();
424 c
= gfc_peek_char ();
428 /* Found a statement label? */
429 m
= gfc_match_st_label (&gfc_statement_label
);
431 d
= gfc_peek_char ();
432 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
434 gfc_match_small_literal_int (&c
, &cnt
);
437 gfc_error_now ("Too many digits in statement label at %C");
440 gfc_error_now ("Zero is not a valid statement label at %C");
443 c
= gfc_next_char ();
446 if (!gfc_is_whitespace (c
))
447 gfc_error_now ("Non-numeric character in statement label at %C");
453 label_locus
= gfc_current_locus
;
455 gfc_gobble_whitespace ();
457 if (at_bol
&& gfc_peek_char () == ';')
459 gfc_error_now ("Semicolon at %C needs to be preceded by "
461 gfc_next_char (); /* Eat up the semicolon. */
465 if (gfc_match_eos () == MATCH_YES
)
467 gfc_warning_now ("Ignoring statement label in empty statement "
469 gfc_free_st_label (gfc_statement_label
);
470 gfc_statement_label
= NULL
;
477 /* Comments have already been skipped by the time we get here,
478 except for OpenMP directives. */
479 if (gfc_option
.flag_openmp
)
483 c
= gfc_next_char ();
484 for (i
= 0; i
< 5; i
++, c
= gfc_next_char ())
485 gcc_assert (c
== "!$omp"[i
]);
487 gcc_assert (c
== ' ');
488 gfc_gobble_whitespace ();
489 return decode_omp_directive ();
493 if (at_bol
&& c
== ';')
495 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
496 gfc_next_char (); /* Eat up the semicolon. */
500 return decode_statement ();
504 /* Get the next statement in fixed-form source. */
509 int label
, digit_flag
, i
;
514 return decode_statement ();
516 /* Skip past the current label field, parsing a statement label if
517 one is there. This is a weird number parser, since the number is
518 contained within five columns and can have any kind of embedded
519 spaces. We also check for characters that make the rest of the
525 for (i
= 0; i
< 5; i
++)
527 c
= gfc_next_char_literal (0);
544 label
= label
* 10 + c
- '0';
545 label_locus
= gfc_current_locus
;
549 /* Comments have already been skipped by the time we get
550 here, except for OpenMP directives. */
552 if (gfc_option
.flag_openmp
)
554 for (i
= 0; i
< 5; i
++, c
= gfc_next_char_literal (0))
555 gcc_assert (TOLOWER (c
) == "*$omp"[i
]);
557 if (c
!= ' ' && c
!= '0')
559 gfc_buffer_error (0);
560 gfc_error ("Bad continuation line at %C");
564 return decode_omp_directive ();
568 /* Comments have already been skipped by the time we get
569 here so don't bother checking for them. */
572 gfc_buffer_error (0);
573 gfc_error ("Non-numeric character in statement label at %C");
581 gfc_warning_now ("Zero is not a valid statement label at %C");
584 /* We've found a valid statement label. */
585 gfc_statement_label
= gfc_get_st_label (label
);
589 /* Since this line starts a statement, it cannot be a continuation
590 of a previous statement. If we see something here besides a
591 space or zero, it must be a bad continuation line. */
593 c
= gfc_next_char_literal (0);
597 if (c
!= ' ' && c
!= '0')
599 gfc_buffer_error (0);
600 gfc_error ("Bad continuation line at %C");
604 /* Now that we've taken care of the statement label columns, we have
605 to make sure that the first nonblank character is not a '!'. If
606 it is, the rest of the line is a comment. */
610 loc
= gfc_current_locus
;
611 c
= gfc_next_char_literal (0);
613 while (gfc_is_whitespace (c
));
617 gfc_current_locus
= loc
;
621 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
625 if (gfc_match_eos () == MATCH_YES
)
628 /* At this point, we've got a nonblank statement to parse. */
629 return decode_statement ();
633 gfc_warning ("Ignoring statement label in empty statement at %C");
639 /* Return the next non-ST_NONE statement to the caller. We also worry
640 about including files and the ends of include files at this stage. */
643 next_statement (void)
647 gfc_new_block
= NULL
;
651 gfc_statement_label
= NULL
;
652 gfc_buffer_error (1);
656 if (gfc_option
.warn_line_truncation
657 && gfc_current_locus
.lb
658 && gfc_current_locus
.lb
->truncated
)
659 gfc_warning_now ("Line truncated at %C");
664 gfc_skip_comments ();
672 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
678 gfc_buffer_error (0);
681 check_statement_label (st
);
687 /****************************** Parser ***********************************/
689 /* The parser subroutines are of type 'try' that fail if the file ends
692 /* Macros that expand to case-labels for various classes of
693 statements. Start with executable statements that directly do
696 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
697 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
698 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
699 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
700 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
701 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
702 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
703 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
706 /* Statements that mark other executable statements. */
708 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
709 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
710 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
711 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
712 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
713 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
715 /* Declaration statements */
717 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
718 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
719 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
721 /* Block end statements. Errors associated with interchanging these
722 are detected in gfc_match_end(). */
724 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
725 case ST_END_PROGRAM: case ST_END_SUBROUTINE
728 /* Push a new state onto the stack. */
731 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
733 p
->state
= new_state
;
734 p
->previous
= gfc_state_stack
;
736 p
->head
= p
->tail
= NULL
;
737 p
->do_variable
= NULL
;
742 /* Pop the current state. */
747 gfc_state_stack
= gfc_state_stack
->previous
;
751 /* Try to find the given state in the state stack. */
754 gfc_find_state (gfc_compile_state state
)
758 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
759 if (p
->state
== state
)
762 return (p
== NULL
) ? FAILURE
: SUCCESS
;
766 /* Starts a new level in the statement list. */
769 new_level (gfc_code
*q
)
773 p
= q
->block
= gfc_get_code ();
775 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
781 /* Add the current new_st code structure and adds it to the current
782 program unit. As a side-effect, it zeroes the new_st. */
792 p
->loc
= gfc_current_locus
;
794 if (gfc_state_stack
->head
== NULL
)
795 gfc_state_stack
->head
= p
;
797 gfc_state_stack
->tail
->next
= p
;
799 while (p
->next
!= NULL
)
802 gfc_state_stack
->tail
= p
;
810 /* Frees everything associated with the current statement. */
813 undo_new_statement (void)
815 gfc_free_statements (new_st
.block
);
816 gfc_free_statements (new_st
.next
);
817 gfc_free_statement (&new_st
);
822 /* If the current statement has a statement label, make sure that it
823 is allowed to, or should have one. */
826 check_statement_label (gfc_statement st
)
830 if (gfc_statement_label
== NULL
)
833 gfc_error ("FORMAT statement at %L does not have a statement label",
841 case ST_END_FUNCTION
:
842 case ST_END_SUBROUTINE
:
848 type
= ST_LABEL_TARGET
;
852 type
= ST_LABEL_FORMAT
;
855 /* Statement labels are not restricted from appearing on a
856 particular line. However, there are plenty of situations
857 where the resulting label can't be referenced. */
860 type
= ST_LABEL_BAD_TARGET
;
864 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
866 new_st
.here
= gfc_statement_label
;
870 /* Figures out what the enclosing program unit is. This will be a
871 function, subroutine, program, block data or module. */
874 gfc_enclosing_unit (gfc_compile_state
* result
)
878 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
879 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
880 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
881 || p
->state
== COMP_PROGRAM
)
890 *result
= COMP_PROGRAM
;
895 /* Translate a statement enum to a string. */
898 gfc_ascii_statement (gfc_statement st
)
904 case ST_ARITHMETIC_IF
:
905 p
= _("arithmetic IF");
911 p
= _("attribute declaration");
941 p
= _("data declaration");
949 case ST_DERIVED_DECL
:
950 p
= _("derived type declaration");
964 case ST_END_BLOCK_DATA
:
965 p
= "END BLOCK DATA";
976 case ST_END_FUNCTION
:
982 case ST_END_INTERFACE
:
994 case ST_END_SUBROUTINE
:
995 p
= "END SUBROUTINE";
1006 case ST_EQUIVALENCE
:
1015 case ST_FORALL_BLOCK
: /* Fall through */
1034 case ST_IMPLICIT_NONE
:
1035 p
= "IMPLICIT NONE";
1037 case ST_IMPLIED_ENDDO
:
1038 p
= _("implied END DO");
1064 case ST_MODULE_PROC
:
1065 p
= "MODULE PROCEDURE";
1100 case ST_WHERE_BLOCK
: /* Fall through */
1108 p
= _("assignment");
1110 case ST_POINTER_ASSIGNMENT
:
1111 p
= _("pointer assignment");
1113 case ST_SELECT_CASE
:
1122 case ST_STATEMENT_FUNCTION
:
1123 p
= "STATEMENT FUNCTION";
1125 case ST_LABEL_ASSIGNMENT
:
1126 p
= "LABEL ASSIGNMENT";
1129 p
= "ENUM DEFINITION";
1132 p
= "ENUMERATOR DEFINITION";
1140 case ST_OMP_BARRIER
:
1141 p
= "!$OMP BARRIER";
1143 case ST_OMP_CRITICAL
:
1144 p
= "!$OMP CRITICAL";
1149 case ST_OMP_END_CRITICAL
:
1150 p
= "!$OMP END CRITICAL";
1155 case ST_OMP_END_MASTER
:
1156 p
= "!$OMP END MASTER";
1158 case ST_OMP_END_ORDERED
:
1159 p
= "!$OMP END ORDERED";
1161 case ST_OMP_END_PARALLEL
:
1162 p
= "!$OMP END PARALLEL";
1164 case ST_OMP_END_PARALLEL_DO
:
1165 p
= "!$OMP END PARALLEL DO";
1167 case ST_OMP_END_PARALLEL_SECTIONS
:
1168 p
= "!$OMP END PARALLEL SECTIONS";
1170 case ST_OMP_END_PARALLEL_WORKSHARE
:
1171 p
= "!$OMP END PARALLEL WORKSHARE";
1173 case ST_OMP_END_SECTIONS
:
1174 p
= "!$OMP END SECTIONS";
1176 case ST_OMP_END_SINGLE
:
1177 p
= "!$OMP END SINGLE";
1179 case ST_OMP_END_WORKSHARE
:
1180 p
= "!$OMP END WORKSHARE";
1188 case ST_OMP_ORDERED
:
1189 p
= "!$OMP ORDERED";
1191 case ST_OMP_PARALLEL
:
1192 p
= "!$OMP PARALLEL";
1194 case ST_OMP_PARALLEL_DO
:
1195 p
= "!$OMP PARALLEL DO";
1197 case ST_OMP_PARALLEL_SECTIONS
:
1198 p
= "!$OMP PARALLEL SECTIONS";
1200 case ST_OMP_PARALLEL_WORKSHARE
:
1201 p
= "!$OMP PARALLEL WORKSHARE";
1203 case ST_OMP_SECTIONS
:
1204 p
= "!$OMP SECTIONS";
1206 case ST_OMP_SECTION
:
1207 p
= "!$OMP SECTION";
1212 case ST_OMP_THREADPRIVATE
:
1213 p
= "!$OMP THREADPRIVATE";
1215 case ST_OMP_WORKSHARE
:
1216 p
= "!$OMP WORKSHARE";
1219 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1226 /* Create a symbol for the main program and assign it to ns->proc_name. */
1229 main_program_symbol (gfc_namespace
*ns
)
1231 gfc_symbol
*main_program
;
1232 symbol_attribute attr
;
1234 gfc_get_symbol ("MAIN__", ns
, &main_program
);
1235 gfc_clear_attr (&attr
);
1236 attr
.flavor
= FL_PROCEDURE
;
1237 attr
.proc
= PROC_UNKNOWN
;
1238 attr
.subroutine
= 1;
1239 attr
.access
= ACCESS_PUBLIC
;
1240 attr
.is_main_program
= 1;
1241 main_program
->attr
= attr
;
1242 main_program
->declared_at
= gfc_current_locus
;
1243 ns
->proc_name
= main_program
;
1244 gfc_commit_symbols ();
1248 /* Do whatever is necessary to accept the last statement. */
1251 accept_statement (gfc_statement st
)
1259 case ST_IMPLICIT_NONE
:
1260 gfc_set_implicit_none ();
1269 gfc_current_ns
->proc_name
= gfc_new_block
;
1272 /* If the statement is the end of a block, lay down a special code
1273 that allows a branch to the end of the block from within the
1278 if (gfc_statement_label
!= NULL
)
1280 new_st
.op
= EXEC_NOP
;
1286 /* The end-of-program unit statements do not get the special
1287 marker and require a statement of some sort if they are a
1290 case ST_END_PROGRAM
:
1291 case ST_END_FUNCTION
:
1292 case ST_END_SUBROUTINE
:
1293 if (gfc_statement_label
!= NULL
)
1295 new_st
.op
= EXEC_RETURN
;
1311 gfc_commit_symbols ();
1312 gfc_warning_check ();
1313 gfc_clear_new_st ();
1317 /* Undo anything tentative that has been built for the current
1321 reject_statement (void)
1323 gfc_new_block
= NULL
;
1324 gfc_undo_symbols ();
1325 gfc_clear_warning ();
1326 undo_new_statement ();
1330 /* Generic complaint about an out of order statement. We also do
1331 whatever is necessary to clean up. */
1334 unexpected_statement (gfc_statement st
)
1336 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1338 reject_statement ();
1342 /* Given the next statement seen by the matcher, make sure that it is
1343 in proper order with the last. This subroutine is initialized by
1344 calling it with an argument of ST_NONE. If there is a problem, we
1345 issue an error and return FAILURE. Otherwise we return SUCCESS.
1347 Individual parsers need to verify that the statements seen are
1348 valid before calling here, ie ENTRY statements are not allowed in
1349 INTERFACE blocks. The following diagram is taken from the standard:
1351 +---------------------------------------+
1352 | program subroutine function module |
1353 +---------------------------------------+
1355 +---------------------------------------+
1357 +---------------------------------------+
1359 | +-----------+------------------+
1360 | | parameter | implicit |
1361 | +-----------+------------------+
1362 | format | | derived type |
1363 | entry | parameter | interface |
1364 | | data | specification |
1365 | | | statement func |
1366 | +-----------+------------------+
1367 | | data | executable |
1368 +--------+-----------+------------------+
1370 +---------------------------------------+
1371 | internal module/subprogram |
1372 +---------------------------------------+
1374 +---------------------------------------+
1381 { ORDER_START
, ORDER_USE
, ORDER_IMPORT
, ORDER_IMPLICIT_NONE
,
1382 ORDER_IMPLICIT
, ORDER_SPEC
, ORDER_EXEC
1385 gfc_statement last_statement
;
1391 verify_st_order (st_state
*p
, gfc_statement st
)
1397 p
->state
= ORDER_START
;
1401 if (p
->state
> ORDER_USE
)
1403 p
->state
= ORDER_USE
;
1407 if (p
->state
> ORDER_IMPORT
)
1409 p
->state
= ORDER_IMPORT
;
1412 case ST_IMPLICIT_NONE
:
1413 if (p
->state
> ORDER_IMPLICIT_NONE
)
1416 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1417 statement disqualifies a USE but not an IMPLICIT NONE.
1418 Duplicate IMPLICIT NONEs are caught when the implicit types
1421 p
->state
= ORDER_IMPLICIT_NONE
;
1425 if (p
->state
> ORDER_IMPLICIT
)
1427 p
->state
= ORDER_IMPLICIT
;
1432 if (p
->state
< ORDER_IMPLICIT_NONE
)
1433 p
->state
= ORDER_IMPLICIT_NONE
;
1437 if (p
->state
>= ORDER_EXEC
)
1439 if (p
->state
< ORDER_IMPLICIT
)
1440 p
->state
= ORDER_IMPLICIT
;
1444 if (p
->state
< ORDER_SPEC
)
1445 p
->state
= ORDER_SPEC
;
1450 case ST_DERIVED_DECL
:
1452 if (p
->state
>= ORDER_EXEC
)
1454 if (p
->state
< ORDER_SPEC
)
1455 p
->state
= ORDER_SPEC
;
1460 if (p
->state
< ORDER_EXEC
)
1461 p
->state
= ORDER_EXEC
;
1465 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1466 gfc_ascii_statement (st
));
1469 /* All is well, record the statement in case we need it next time. */
1470 p
->where
= gfc_current_locus
;
1471 p
->last_statement
= st
;
1475 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1476 gfc_ascii_statement (st
),
1477 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1483 /* Handle an unexpected end of file. This is a show-stopper... */
1485 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1488 unexpected_eof (void)
1492 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1494 /* Memory cleanup. Move to "second to last". */
1495 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1498 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1501 longjmp (eof_buf
, 1);
1505 /* Parse a derived type. */
1508 parse_derived (void)
1510 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1518 accept_statement (ST_DERIVED_DECL
);
1519 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1521 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1528 while (compiling_type
)
1530 st
= next_statement ();
1537 accept_statement (st
);
1544 if (!seen_component
)
1546 gfc_error ("Derived type definition at %C has no components");
1550 accept_statement (ST_END_TYPE
);
1554 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1556 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1564 gfc_error ("PRIVATE statement at %C must precede "
1565 "structure components");
1572 gfc_error ("Duplicate PRIVATE statement at %C");
1576 s
.sym
->component_access
= ACCESS_PRIVATE
;
1577 accept_statement (ST_PRIVATE
);
1584 gfc_error ("SEQUENCE statement at %C must precede "
1585 "structure components");
1590 if (gfc_current_block ()->attr
.sequence
)
1591 gfc_warning ("SEQUENCE attribute at %C already specified in "
1596 gfc_error ("Duplicate SEQUENCE statement at %C");
1601 gfc_add_sequence (&gfc_current_block ()->attr
,
1602 gfc_current_block ()->name
, NULL
);
1606 unexpected_statement (st
);
1611 /* Look for allocatable components. */
1612 sym
= gfc_current_block ();
1613 for (c
= sym
->components
; c
; c
= c
->next
)
1616 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.alloc_comp
))
1618 sym
->attr
.alloc_comp
= 1;
1627 /* Parse an ENUM. */
1636 int seen_enumerator
= 0;
1640 push_state (&s
, COMP_ENUM
, gfc_new_block
);
1644 while (compiling_enum
)
1646 st
= next_statement ();
1654 seen_enumerator
= 1;
1655 accept_statement (st
);
1660 if (!seen_enumerator
)
1662 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1665 accept_statement (st
);
1669 gfc_free_enum_history ();
1670 unexpected_statement (st
);
1678 /* Parse an interface. We must be able to deal with the possibility
1679 of recursive interfaces. The parse_spec() subroutine is mutually
1680 recursive with parse_interface(). */
1682 static gfc_statement
parse_spec (gfc_statement
);
1685 parse_interface (void)
1687 gfc_compile_state new_state
, current_state
;
1688 gfc_symbol
*prog_unit
, *sym
;
1689 gfc_interface_info save
;
1690 gfc_state_data s1
, s2
;
1694 accept_statement (ST_INTERFACE
);
1696 current_interface
.ns
= gfc_current_ns
;
1697 save
= current_interface
;
1699 sym
= (current_interface
.type
== INTERFACE_GENERIC
1700 || current_interface
.type
== INTERFACE_USER_OP
)
1701 ? gfc_new_block
: NULL
;
1703 push_state (&s1
, COMP_INTERFACE
, sym
);
1704 current_state
= COMP_NONE
;
1707 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1709 st
= next_statement ();
1716 new_state
= COMP_SUBROUTINE
;
1717 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1718 gfc_new_block
->formal
, NULL
);
1722 new_state
= COMP_FUNCTION
;
1723 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1724 gfc_new_block
->formal
, NULL
);
1727 case ST_MODULE_PROC
: /* The module procedure matcher makes
1728 sure the context is correct. */
1729 accept_statement (st
);
1730 gfc_free_namespace (gfc_current_ns
);
1733 case ST_END_INTERFACE
:
1734 gfc_free_namespace (gfc_current_ns
);
1735 gfc_current_ns
= current_interface
.ns
;
1739 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1740 gfc_ascii_statement (st
));
1741 reject_statement ();
1742 gfc_free_namespace (gfc_current_ns
);
1747 /* Make sure that a generic interface has only subroutines or
1748 functions and that the generic name has the right attribute. */
1749 if (current_interface
.type
== INTERFACE_GENERIC
)
1751 if (current_state
== COMP_NONE
)
1753 if (new_state
== COMP_FUNCTION
)
1754 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1755 else if (new_state
== COMP_SUBROUTINE
)
1756 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1758 current_state
= new_state
;
1762 if (new_state
!= current_state
)
1764 if (new_state
== COMP_SUBROUTINE
)
1765 gfc_error ("SUBROUTINE at %C does not belong in a "
1766 "generic function interface");
1768 if (new_state
== COMP_FUNCTION
)
1769 gfc_error ("FUNCTION at %C does not belong in a "
1770 "generic subroutine interface");
1775 push_state (&s2
, new_state
, gfc_new_block
);
1776 accept_statement (st
);
1777 prog_unit
= gfc_new_block
;
1778 prog_unit
->formal_ns
= gfc_current_ns
;
1779 proc_locus
= gfc_current_locus
;
1782 /* Read data declaration statements. */
1783 st
= parse_spec (ST_NONE
);
1785 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1787 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1788 gfc_ascii_statement (st
));
1789 reject_statement ();
1793 current_interface
= save
;
1794 gfc_add_interface (prog_unit
);
1797 if (current_interface
.ns
1798 && current_interface
.ns
->proc_name
1799 && strcmp (current_interface
.ns
->proc_name
->name
,
1800 prog_unit
->name
) == 0)
1801 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1802 "enclosing procedure", prog_unit
->name
, &proc_locus
);
1811 /* Parse a set of specification statements. Returns the statement
1812 that doesn't fit. */
1814 static gfc_statement
1815 parse_spec (gfc_statement st
)
1819 verify_st_order (&ss
, ST_NONE
);
1821 st
= next_statement ();
1831 case ST_DATA
: /* Not allowed in interfaces */
1832 if (gfc_current_state () == COMP_INTERFACE
)
1839 case ST_IMPLICIT_NONE
:
1844 case ST_DERIVED_DECL
:
1846 if (verify_st_order (&ss
, st
) == FAILURE
)
1848 reject_statement ();
1849 st
= next_statement ();
1859 case ST_DERIVED_DECL
:
1865 if (gfc_current_state () != COMP_MODULE
)
1867 gfc_error ("%s statement must appear in a MODULE",
1868 gfc_ascii_statement (st
));
1872 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1874 gfc_error ("%s statement at %C follows another accessibility "
1875 "specification", gfc_ascii_statement (st
));
1879 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1880 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1888 accept_statement (st
);
1889 st
= next_statement ();
1893 accept_statement (st
);
1895 st
= next_statement ();
1906 /* Parse a WHERE block, (not a simple WHERE statement). */
1909 parse_where_block (void)
1911 int seen_empty_else
;
1916 accept_statement (ST_WHERE_BLOCK
);
1917 top
= gfc_state_stack
->tail
;
1919 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1921 d
= add_statement ();
1922 d
->expr
= top
->expr
;
1928 seen_empty_else
= 0;
1932 st
= next_statement ();
1938 case ST_WHERE_BLOCK
:
1939 parse_where_block ();
1944 accept_statement (st
);
1948 if (seen_empty_else
)
1950 gfc_error ("ELSEWHERE statement at %C follows previous "
1951 "unmasked ELSEWHERE");
1955 if (new_st
.expr
== NULL
)
1956 seen_empty_else
= 1;
1958 d
= new_level (gfc_state_stack
->head
);
1960 d
->expr
= new_st
.expr
;
1962 accept_statement (st
);
1967 accept_statement (st
);
1971 gfc_error ("Unexpected %s statement in WHERE block at %C",
1972 gfc_ascii_statement (st
));
1973 reject_statement ();
1977 while (st
!= ST_END_WHERE
);
1983 /* Parse a FORALL block (not a simple FORALL statement). */
1986 parse_forall_block (void)
1992 accept_statement (ST_FORALL_BLOCK
);
1993 top
= gfc_state_stack
->tail
;
1995 push_state (&s
, COMP_FORALL
, gfc_new_block
);
1997 d
= add_statement ();
1998 d
->op
= EXEC_FORALL
;
2003 st
= next_statement ();
2008 case ST_POINTER_ASSIGNMENT
:
2011 accept_statement (st
);
2014 case ST_WHERE_BLOCK
:
2015 parse_where_block ();
2018 case ST_FORALL_BLOCK
:
2019 parse_forall_block ();
2023 accept_statement (st
);
2030 gfc_error ("Unexpected %s statement in FORALL block at %C",
2031 gfc_ascii_statement (st
));
2033 reject_statement ();
2037 while (st
!= ST_END_FORALL
);
2043 static gfc_statement
parse_executable (gfc_statement
);
2045 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2048 parse_if_block (void)
2057 accept_statement (ST_IF_BLOCK
);
2059 top
= gfc_state_stack
->tail
;
2060 push_state (&s
, COMP_IF
, gfc_new_block
);
2062 new_st
.op
= EXEC_IF
;
2063 d
= add_statement ();
2065 d
->expr
= top
->expr
;
2071 st
= parse_executable (ST_NONE
);
2081 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2082 "statement at %L", &else_locus
);
2084 reject_statement ();
2088 d
= new_level (gfc_state_stack
->head
);
2090 d
->expr
= new_st
.expr
;
2092 accept_statement (st
);
2099 gfc_error ("Duplicate ELSE statements at %L and %C",
2101 reject_statement ();
2106 else_locus
= gfc_current_locus
;
2108 d
= new_level (gfc_state_stack
->head
);
2111 accept_statement (st
);
2119 unexpected_statement (st
);
2123 while (st
!= ST_ENDIF
);
2126 accept_statement (st
);
2130 /* Parse a SELECT block. */
2133 parse_select_block (void)
2139 accept_statement (ST_SELECT_CASE
);
2141 cp
= gfc_state_stack
->tail
;
2142 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2144 /* Make sure that the next statement is a CASE or END SELECT. */
2147 st
= next_statement ();
2150 if (st
== ST_END_SELECT
)
2152 /* Empty SELECT CASE is OK. */
2153 accept_statement (st
);
2160 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2163 reject_statement ();
2166 /* At this point, we're got a nonempty select block. */
2167 cp
= new_level (cp
);
2170 accept_statement (st
);
2174 st
= parse_executable (ST_NONE
);
2181 cp
= new_level (gfc_state_stack
->head
);
2183 gfc_clear_new_st ();
2185 accept_statement (st
);
2191 /* Can't have an executable statement because of
2192 parse_executable(). */
2194 unexpected_statement (st
);
2198 while (st
!= ST_END_SELECT
);
2201 accept_statement (st
);
2205 /* Given a symbol, make sure it is not an iteration variable for a DO
2206 statement. This subroutine is called when the symbol is seen in a
2207 context that causes it to become redefined. If the symbol is an
2208 iterator, we generate an error message and return nonzero. */
2211 gfc_check_do_variable (gfc_symtree
*st
)
2215 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2216 if (s
->do_variable
== st
)
2218 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2219 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2227 /* Checks to see if the current statement label closes an enddo.
2228 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2229 an error) if it incorrectly closes an ENDDO. */
2232 check_do_closure (void)
2236 if (gfc_statement_label
== NULL
)
2239 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2240 if (p
->state
== COMP_DO
)
2244 return 0; /* No loops to close */
2246 if (p
->ext
.end_do_label
== gfc_statement_label
)
2249 if (p
== gfc_state_stack
)
2252 gfc_error ("End of nonblock DO statement at %C is within another block");
2256 /* At this point, the label doesn't terminate the innermost loop.
2257 Make sure it doesn't terminate another one. */
2258 for (; p
; p
= p
->previous
)
2259 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
2261 gfc_error ("End of nonblock DO statement at %C is interwoven "
2262 "with another DO loop");
2270 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2271 handled inside of parse_executable(), because they aren't really
2275 parse_do_block (void)
2282 s
.ext
.end_do_label
= new_st
.label
;
2284 if (new_st
.ext
.iterator
!= NULL
)
2285 stree
= new_st
.ext
.iterator
->var
->symtree
;
2289 accept_statement (ST_DO
);
2291 top
= gfc_state_stack
->tail
;
2292 push_state (&s
, COMP_DO
, gfc_new_block
);
2294 s
.do_variable
= stree
;
2296 top
->block
= new_level (top
);
2297 top
->block
->op
= EXEC_DO
;
2300 st
= parse_executable (ST_NONE
);
2308 if (s
.ext
.end_do_label
!= NULL
2309 && s
.ext
.end_do_label
!= gfc_statement_label
)
2310 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2313 if (gfc_statement_label
!= NULL
)
2315 new_st
.op
= EXEC_NOP
;
2320 case ST_IMPLIED_ENDDO
:
2321 /* If the do-stmt of this DO construct has a do-construct-name,
2322 the corresponding end-do must be an end-do-stmt (with a matching
2323 name, but in that case we must have seen ST_ENDDO first).
2324 We only complain about this in pedantic mode. */
2325 if (gfc_current_block () != NULL
)
2326 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2327 &gfc_current_block()->declared_at
);
2332 unexpected_statement (st
);
2337 accept_statement (st
);
2341 /* Parse the statements of OpenMP do/parallel do. */
2343 static gfc_statement
2344 parse_omp_do (gfc_statement omp_st
)
2350 accept_statement (omp_st
);
2352 cp
= gfc_state_stack
->tail
;
2353 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2354 np
= new_level (cp
);
2360 st
= next_statement ();
2363 else if (st
== ST_DO
)
2366 unexpected_statement (st
);
2370 if (gfc_statement_label
!= NULL
2371 && gfc_state_stack
->previous
!= NULL
2372 && gfc_state_stack
->previous
->state
== COMP_DO
2373 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
2381 there should be no !$OMP END DO. */
2383 return ST_IMPLIED_ENDDO
;
2386 check_do_closure ();
2389 st
= next_statement ();
2390 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
2392 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
2393 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2395 gcc_assert (new_st
.op
== EXEC_NOP
);
2396 gfc_clear_new_st ();
2397 gfc_commit_symbols ();
2398 gfc_warning_check ();
2399 st
= next_statement ();
2405 /* Parse the statements of OpenMP atomic directive. */
2408 parse_omp_atomic (void)
2414 accept_statement (ST_OMP_ATOMIC
);
2416 cp
= gfc_state_stack
->tail
;
2417 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2418 np
= new_level (cp
);
2424 st
= next_statement ();
2427 else if (st
== ST_ASSIGNMENT
)
2430 unexpected_statement (st
);
2433 accept_statement (st
);
2439 /* Parse the statements of an OpenMP structured block. */
2442 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
2444 gfc_statement st
, omp_end_st
;
2448 accept_statement (omp_st
);
2450 cp
= gfc_state_stack
->tail
;
2451 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2452 np
= new_level (cp
);
2458 case ST_OMP_PARALLEL
:
2459 omp_end_st
= ST_OMP_END_PARALLEL
;
2461 case ST_OMP_PARALLEL_SECTIONS
:
2462 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
2464 case ST_OMP_SECTIONS
:
2465 omp_end_st
= ST_OMP_END_SECTIONS
;
2467 case ST_OMP_ORDERED
:
2468 omp_end_st
= ST_OMP_END_ORDERED
;
2470 case ST_OMP_CRITICAL
:
2471 omp_end_st
= ST_OMP_END_CRITICAL
;
2474 omp_end_st
= ST_OMP_END_MASTER
;
2477 omp_end_st
= ST_OMP_END_SINGLE
;
2479 case ST_OMP_WORKSHARE
:
2480 omp_end_st
= ST_OMP_END_WORKSHARE
;
2482 case ST_OMP_PARALLEL_WORKSHARE
:
2483 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
2491 if (workshare_stmts_only
)
2493 /* Inside of !$omp workshare, only
2496 where statements and constructs
2497 forall statements and constructs
2501 are allowed. For !$omp critical these
2502 restrictions apply recursively. */
2505 st
= next_statement ();
2516 accept_statement (st
);
2519 case ST_WHERE_BLOCK
:
2520 parse_where_block ();
2523 case ST_FORALL_BLOCK
:
2524 parse_forall_block ();
2527 case ST_OMP_PARALLEL
:
2528 case ST_OMP_PARALLEL_SECTIONS
:
2529 parse_omp_structured_block (st
, false);
2532 case ST_OMP_PARALLEL_WORKSHARE
:
2533 case ST_OMP_CRITICAL
:
2534 parse_omp_structured_block (st
, true);
2537 case ST_OMP_PARALLEL_DO
:
2538 st
= parse_omp_do (st
);
2542 parse_omp_atomic ();
2553 st
= next_statement ();
2557 st
= parse_executable (ST_NONE
);
2560 else if (st
== ST_OMP_SECTION
2561 && (omp_st
== ST_OMP_SECTIONS
2562 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
2564 np
= new_level (np
);
2568 else if (st
!= omp_end_st
)
2569 unexpected_statement (st
);
2571 while (st
!= omp_end_st
);
2575 case EXEC_OMP_END_NOWAIT
:
2576 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2578 case EXEC_OMP_CRITICAL
:
2579 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
2580 || (new_st
.ext
.omp_name
!= NULL
2581 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
2582 gfc_error ("Name after !$omp critical and !$omp end critical does "
2584 gfc_free ((char *) new_st
.ext
.omp_name
);
2586 case EXEC_OMP_END_SINGLE
:
2587 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
2588 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
2589 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
2590 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
2598 gfc_clear_new_st ();
2599 gfc_commit_symbols ();
2600 gfc_warning_check ();
2605 /* Accept a series of executable statements. We return the first
2606 statement that doesn't fit to the caller. Any block statements are
2607 passed on to the correct handler, which usually passes the buck
2610 static gfc_statement
2611 parse_executable (gfc_statement st
)
2616 st
= next_statement ();
2620 close_flag
= check_do_closure ();
2625 case ST_END_PROGRAM
:
2628 case ST_END_FUNCTION
:
2632 case ST_END_SUBROUTINE
:
2637 case ST_SELECT_CASE
:
2638 gfc_error ("%s statement at %C cannot terminate a non-block "
2639 "DO loop", gfc_ascii_statement (st
));
2655 accept_statement (st
);
2656 if (close_flag
== 1)
2657 return ST_IMPLIED_ENDDO
;
2664 case ST_SELECT_CASE
:
2665 parse_select_block ();
2670 if (check_do_closure () == 1)
2671 return ST_IMPLIED_ENDDO
;
2674 case ST_WHERE_BLOCK
:
2675 parse_where_block ();
2678 case ST_FORALL_BLOCK
:
2679 parse_forall_block ();
2682 case ST_OMP_PARALLEL
:
2683 case ST_OMP_PARALLEL_SECTIONS
:
2684 case ST_OMP_SECTIONS
:
2685 case ST_OMP_ORDERED
:
2686 case ST_OMP_CRITICAL
:
2689 parse_omp_structured_block (st
, false);
2692 case ST_OMP_WORKSHARE
:
2693 case ST_OMP_PARALLEL_WORKSHARE
:
2694 parse_omp_structured_block (st
, true);
2698 case ST_OMP_PARALLEL_DO
:
2699 st
= parse_omp_do (st
);
2700 if (st
== ST_IMPLIED_ENDDO
)
2705 parse_omp_atomic ();
2712 st
= next_statement ();
2717 /* Parse a series of contained program units. */
2719 static void parse_progunit (gfc_statement
);
2722 /* Fix the symbols for sibling functions. These are incorrectly added to
2723 the child namespace as the parser didn't know about this procedure. */
2726 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
2730 gfc_symbol
*old_sym
;
2732 sym
->attr
.referenced
= 1;
2733 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2735 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2737 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
2740 old_sym
= st
->n
.sym
;
2741 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2742 || old_sym
->ts
.type
== BT_UNKNOWN
)
2743 && old_sym
->ns
== ns
2744 && !old_sym
->attr
.contained
)
2746 /* Replace it with the symbol from the parent namespace. */
2750 /* Free the old (local) symbol. */
2752 if (old_sym
->refs
== 0)
2753 gfc_free_symbol (old_sym
);
2756 /* Do the same for any contained procedures. */
2757 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2762 parse_contained (int module
)
2764 gfc_namespace
*ns
, *parent_ns
;
2765 gfc_state_data s1
, s2
;
2769 int contains_statements
= 0;
2771 push_state (&s1
, COMP_CONTAINS
, NULL
);
2772 parent_ns
= gfc_current_ns
;
2776 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
2778 gfc_current_ns
->sibling
= parent_ns
->contained
;
2779 parent_ns
->contained
= gfc_current_ns
;
2781 st
= next_statement ();
2790 contains_statements
= 1;
2791 accept_statement (st
);
2794 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2797 /* For internal procedures, create/update the symbol in the
2798 parent namespace. */
2802 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2803 gfc_error ("Contained procedure '%s' at %C is already "
2804 "ambiguous", gfc_new_block
->name
);
2807 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
2808 &gfc_new_block
->declared_at
) ==
2811 if (st
== ST_FUNCTION
)
2812 gfc_add_function (&sym
->attr
, sym
->name
,
2813 &gfc_new_block
->declared_at
);
2815 gfc_add_subroutine (&sym
->attr
, sym
->name
,
2816 &gfc_new_block
->declared_at
);
2820 gfc_commit_symbols ();
2823 sym
= gfc_new_block
;
2825 /* Mark this as a contained function, so it isn't replaced
2826 by other module functions. */
2827 sym
->attr
.contained
= 1;
2828 sym
->attr
.referenced
= 1;
2830 parse_progunit (ST_NONE
);
2832 /* Fix up any sibling functions that refer to this one. */
2833 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2834 /* Or refer to any of its alternate entry points. */
2835 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2836 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2838 gfc_current_ns
->code
= s2
.head
;
2839 gfc_current_ns
= parent_ns
;
2844 /* These statements are associated with the end of the host unit. */
2845 case ST_END_FUNCTION
:
2847 case ST_END_PROGRAM
:
2848 case ST_END_SUBROUTINE
:
2849 accept_statement (st
);
2853 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2854 gfc_ascii_statement (st
));
2855 reject_statement ();
2859 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2860 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2862 /* The first namespace in the list is guaranteed to not have
2863 anything (worthwhile) in it. */
2865 gfc_current_ns
= parent_ns
;
2867 ns
= gfc_current_ns
->contained
;
2868 gfc_current_ns
->contained
= ns
->sibling
;
2869 gfc_free_namespace (ns
);
2872 if (!contains_statements
)
2873 /* This is valid in Fortran 2008. */
2874 gfc_notify_std (GFC_STD_GNU
, "Extension: CONTAINS statement without "
2875 "FUNCTION or SUBROUTINE statement at %C");
2879 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2882 parse_progunit (gfc_statement st
)
2887 st
= parse_spec (st
);
2897 accept_statement (st
);
2907 st
= parse_executable (st
);
2918 accept_statement (st
);
2925 unexpected_statement (st
);
2926 reject_statement ();
2927 st
= next_statement ();
2933 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2934 if (p
->state
== COMP_CONTAINS
)
2937 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2942 gfc_error ("CONTAINS statement at %C is already in a contained "
2944 st
= next_statement ();
2948 parse_contained (0);
2951 gfc_current_ns
->code
= gfc_state_stack
->head
;
2955 /* Come here to complain about a global symbol already in use as
2959 global_used (gfc_gsymbol
*sym
, locus
*where
)
2964 where
= &gfc_current_locus
;
2974 case GSYM_SUBROUTINE
:
2975 name
= "SUBROUTINE";
2980 case GSYM_BLOCK_DATA
:
2981 name
= "BLOCK DATA";
2987 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2991 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2992 sym
->name
, where
, name
, &sym
->where
);
2996 /* Parse a block data program unit. */
2999 parse_block_data (void)
3002 static locus blank_locus
;
3003 static int blank_block
=0;
3006 gfc_current_ns
->proc_name
= gfc_new_block
;
3007 gfc_current_ns
->is_block_data
= 1;
3009 if (gfc_new_block
== NULL
)
3012 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3013 "prior BLOCK DATA at %L", &blank_locus
);
3017 blank_locus
= gfc_current_locus
;
3022 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3024 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3025 global_used(s
, NULL
);
3028 s
->type
= GSYM_BLOCK_DATA
;
3029 s
->where
= gfc_current_locus
;
3034 st
= parse_spec (ST_NONE
);
3036 while (st
!= ST_END_BLOCK_DATA
)
3038 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3039 gfc_ascii_statement (st
));
3040 reject_statement ();
3041 st
= next_statement ();
3046 /* Parse a module subprogram. */
3054 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3055 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3056 global_used(s
, NULL
);
3059 s
->type
= GSYM_MODULE
;
3060 s
->where
= gfc_current_locus
;
3064 st
= parse_spec (ST_NONE
);
3073 parse_contained (1);
3077 accept_statement (st
);
3081 gfc_error ("Unexpected %s statement in MODULE at %C",
3082 gfc_ascii_statement (st
));
3084 reject_statement ();
3085 st
= next_statement ();
3091 /* Add a procedure name to the global symbol table. */
3094 add_global_procedure (int sub
)
3098 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3101 || (s
->type
!= GSYM_UNKNOWN
3102 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3103 global_used(s
, NULL
);
3106 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3107 s
->where
= gfc_current_locus
;
3113 /* Add a program to the global symbol table. */
3116 add_global_program (void)
3120 if (gfc_new_block
== NULL
)
3122 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3124 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
3125 global_used(s
, NULL
);
3128 s
->type
= GSYM_PROGRAM
;
3129 s
->where
= gfc_current_locus
;
3135 /* Top level parser. */
3138 gfc_parse_file (void)
3140 int seen_program
, errors_before
, errors
;
3141 gfc_state_data top
, s
;
3145 top
.state
= COMP_NONE
;
3147 top
.previous
= NULL
;
3148 top
.head
= top
.tail
= NULL
;
3149 top
.do_variable
= NULL
;
3151 gfc_state_stack
= &top
;
3153 gfc_clear_new_st ();
3155 gfc_statement_label
= NULL
;
3157 if (setjmp (eof_buf
))
3158 return FAILURE
; /* Come here on unexpected EOF */
3162 /* Exit early for empty files. */
3168 st
= next_statement ();
3177 goto duplicate_main
;
3179 prog_locus
= gfc_current_locus
;
3181 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3182 main_program_symbol(gfc_current_ns
);
3183 accept_statement (st
);
3184 add_global_program ();
3185 parse_progunit (ST_NONE
);
3189 add_global_procedure (1);
3190 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
3191 accept_statement (st
);
3192 parse_progunit (ST_NONE
);
3196 add_global_procedure (0);
3197 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
3198 accept_statement (st
);
3199 parse_progunit (ST_NONE
);
3203 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
3204 accept_statement (st
);
3205 parse_block_data ();
3209 push_state (&s
, COMP_MODULE
, gfc_new_block
);
3210 accept_statement (st
);
3212 gfc_get_errors (NULL
, &errors_before
);
3216 /* Anything else starts a nameless main program block. */
3219 goto duplicate_main
;
3221 prog_locus
= gfc_current_locus
;
3223 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3224 main_program_symbol (gfc_current_ns
);
3225 parse_progunit (st
);
3229 gfc_current_ns
->code
= s
.head
;
3231 gfc_resolve (gfc_current_ns
);
3233 /* Dump the parse tree if requested. */
3234 if (gfc_option
.verbose
)
3235 gfc_show_namespace (gfc_current_ns
);
3237 gfc_get_errors (NULL
, &errors
);
3238 if (s
.state
== COMP_MODULE
)
3240 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
3242 gfc_generate_module_code (gfc_current_ns
);
3247 gfc_generate_code (gfc_current_ns
);
3258 /* If we see a duplicate main program, shut down. If the second
3259 instance is an implied main program, ie data decls or executable
3260 statements, we're in for lots of errors. */
3261 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
3262 reject_statement ();