2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
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
31 /* Current statement label. Zero means no statement label. Because
32 new_st can get wiped during statement matching, we have to keep it
35 gfc_st_label
*gfc_statement_label
;
37 static locus label_locus
;
38 static jmp_buf eof_buf
;
40 gfc_state_data
*gfc_state_stack
;
42 /* TODO: Re-order functions to kill these forward decls. */
43 static void check_statement_label (gfc_statement
);
44 static void undo_new_statement (void);
45 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 decode_statement (void)
101 gfc_clear_error (); /* Clear any pending errors. */
102 gfc_clear_warning (); /* Clear any pending warnings. */
104 if (gfc_match_eos () == MATCH_YES
)
107 old_locus
= gfc_current_locus
;
109 /* Try matching a data declaration or function declaration. The
110 input "REALFUNCTIONA(N)" can mean several things in different
111 contexts, so it (and its relatives) get special treatment. */
113 if (gfc_current_state () == COMP_NONE
114 || gfc_current_state () == COMP_INTERFACE
115 || gfc_current_state () == COMP_CONTAINS
)
117 m
= gfc_match_function_decl ();
120 else if (m
== MATCH_ERROR
)
124 gfc_current_locus
= old_locus
;
127 /* Match statements whose error messages are meant to be overwritten
128 by something better. */
130 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
131 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
132 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
134 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
135 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
137 /* Try to match a subroutine statement, which has the same optional
138 prefixes that functions can have. */
140 if (gfc_match_subroutine () == MATCH_YES
)
141 return ST_SUBROUTINE
;
143 gfc_current_locus
= old_locus
;
145 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
146 might begin with a block label. The match functions for these
147 statements are unusual in that their keyword is not seen before
148 the matcher is called. */
150 if (gfc_match_if (&st
) == MATCH_YES
)
153 gfc_current_locus
= old_locus
;
155 if (gfc_match_where (&st
) == MATCH_YES
)
158 gfc_current_locus
= old_locus
;
160 if (gfc_match_forall (&st
) == MATCH_YES
)
163 gfc_current_locus
= old_locus
;
165 match (NULL
, gfc_match_do
, ST_DO
);
166 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
168 /* General statement matching: Instead of testing every possible
169 statement, we eliminate most possibilities by peeking at the
172 c
= gfc_peek_char ();
177 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
178 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
179 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
183 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
184 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
188 match ("call", gfc_match_call
, ST_CALL
);
189 match ("close", gfc_match_close
, ST_CLOSE
);
190 match ("continue", gfc_match_continue
, ST_CONTINUE
);
191 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
192 match ("case", gfc_match_case
, ST_CASE
);
193 match ("common", gfc_match_common
, ST_COMMON
);
194 match ("contains", gfc_match_eos
, ST_CONTAINS
);
198 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
199 match ("data", gfc_match_data
, ST_DATA
);
200 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
204 match ("end file", gfc_match_endfile
, ST_END_FILE
);
205 match ("exit", gfc_match_exit
, ST_EXIT
);
206 match ("else", gfc_match_else
, ST_ELSE
);
207 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
208 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
209 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
211 if (gfc_match_end (&st
) == MATCH_YES
)
214 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
215 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
216 match ("external", gfc_match_external
, ST_ATTR_DECL
);
220 match ("flush", gfc_match_flush
, ST_FLUSH
);
221 match ("format", gfc_match_format
, ST_FORMAT
);
225 match ("go to", gfc_match_goto
, ST_GOTO
);
229 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
230 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
231 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
232 match ("import", gfc_match_import
, ST_IMPORT
);
233 match ("interface", gfc_match_interface
, ST_INTERFACE
);
234 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
235 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
239 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
240 match ("module", gfc_match_module
, ST_MODULE
);
244 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
245 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
249 match ("open", gfc_match_open
, ST_OPEN
);
250 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
254 match ("print", gfc_match_print
, ST_WRITE
);
255 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
256 match ("pause", gfc_match_pause
, ST_PAUSE
);
257 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
258 if (gfc_match_private (&st
) == MATCH_YES
)
260 match ("program", gfc_match_program
, ST_PROGRAM
);
261 if (gfc_match_public (&st
) == MATCH_YES
)
266 match ("read", gfc_match_read
, ST_READ
);
267 match ("return", gfc_match_return
, ST_RETURN
);
268 match ("rewind", gfc_match_rewind
, ST_REWIND
);
272 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
273 match ("stop", gfc_match_stop
, ST_STOP
);
274 match ("save", gfc_match_save
, ST_ATTR_DECL
);
278 match ("target", gfc_match_target
, ST_ATTR_DECL
);
279 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
283 match ("use", gfc_match_use
, ST_USE
);
287 match ("value", gfc_match_value
, ST_ATTR_DECL
);
288 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
292 match ("write", gfc_match_write
, ST_WRITE
);
296 /* All else has failed, so give up. See if any of the matchers has
297 stored an error message of some sort. */
299 if (gfc_error_check () == 0)
300 gfc_error_now ("Unclassifiable statement at %C");
304 gfc_error_recovery ();
310 decode_omp_directive (void)
319 gfc_clear_error (); /* Clear any pending errors. */
320 gfc_clear_warning (); /* Clear any pending warnings. */
324 gfc_error_now ("OpenMP directives at %C may not appear in PURE 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 () == ';')
460 ("Semicolon at %C needs to be preceded by statement");
461 gfc_next_char (); /* Eat up the semicolon. */
465 if (gfc_match_eos () == MATCH_YES
)
468 ("Ignoring statement label in empty statement at %C");
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 return decode_omp_directive ();
492 if (at_bol
&& c
== ';')
494 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
495 gfc_next_char (); /* Eat up the semicolon. */
499 return decode_statement ();
503 /* Get the next statement in fixed-form source. */
508 int label
, digit_flag
, i
;
513 return decode_statement ();
515 /* Skip past the current label field, parsing a statement label if
516 one is there. This is a weird number parser, since the number is
517 contained within five columns and can have any kind of embedded
518 spaces. We also check for characters that make the rest of the
524 for (i
= 0; i
< 5; i
++)
526 c
= gfc_next_char_literal (0);
543 label
= label
* 10 + c
- '0';
544 label_locus
= gfc_current_locus
;
548 /* Comments have already been skipped by the time we get
549 here, except for OpenMP directives. */
551 if (gfc_option
.flag_openmp
)
553 for (i
= 0; i
< 5; i
++, c
= gfc_next_char_literal (0))
554 gcc_assert (TOLOWER (c
) == "*$omp"[i
]);
556 if (c
!= ' ' && c
!= '0')
558 gfc_buffer_error (0);
559 gfc_error ("Bad continuation line at %C");
563 return decode_omp_directive ();
567 /* Comments have already been skipped by the time we get
568 here so don't bother checking for them. */
571 gfc_buffer_error (0);
572 gfc_error ("Non-numeric character in statement label at %C");
580 gfc_warning_now ("Zero is not a valid statement label at %C");
583 /* We've found a valid statement label. */
584 gfc_statement_label
= gfc_get_st_label (label
);
588 /* Since this line starts a statement, it cannot be a continuation
589 of a previous statement. If we see something here besides a
590 space or zero, it must be a bad continuation line. */
592 c
= gfc_next_char_literal (0);
596 if (c
!= ' ' && c
!= '0')
598 gfc_buffer_error (0);
599 gfc_error ("Bad continuation line at %C");
603 /* Now that we've taken care of the statement label columns, we have
604 to make sure that the first nonblank character is not a '!'. If
605 it is, the rest of the line is a comment. */
609 loc
= gfc_current_locus
;
610 c
= gfc_next_char_literal (0);
612 while (gfc_is_whitespace (c
));
616 gfc_current_locus
= loc
;
620 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
624 if (gfc_match_eos () == MATCH_YES
)
627 /* At this point, we've got a nonblank statement to parse. */
628 return decode_statement ();
632 gfc_warning ("Ignoring statement label in empty statement at %C");
638 /* Return the next non-ST_NONE statement to the caller. We also worry
639 about including files and the ends of include files at this stage. */
642 next_statement (void)
646 gfc_new_block
= NULL
;
650 gfc_statement_label
= NULL
;
651 gfc_buffer_error (1);
655 if (gfc_option
.warn_line_truncation
656 && gfc_current_locus
.lb
657 && gfc_current_locus
.lb
->truncated
)
658 gfc_warning_now ("Line truncated at %C");
663 gfc_skip_comments ();
672 (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
)
734 p
->state
= new_state
;
735 p
->previous
= gfc_state_stack
;
737 p
->head
= p
->tail
= NULL
;
738 p
->do_variable
= NULL
;
744 /* Pop the current state. */
750 gfc_state_stack
= gfc_state_stack
->previous
;
754 /* Try to find the given state in the state stack. */
757 gfc_find_state (gfc_compile_state state
)
761 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
762 if (p
->state
== state
)
765 return (p
== NULL
) ? FAILURE
: SUCCESS
;
769 /* Starts a new level in the statement list. */
772 new_level (gfc_code
* q
)
776 p
= q
->block
= gfc_get_code ();
778 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
784 /* Add the current new_st code structure and adds it to the current
785 program unit. As a side-effect, it zeroes the new_st. */
795 p
->loc
= gfc_current_locus
;
797 if (gfc_state_stack
->head
== NULL
)
798 gfc_state_stack
->head
= p
;
800 gfc_state_stack
->tail
->next
= p
;
802 while (p
->next
!= NULL
)
805 gfc_state_stack
->tail
= p
;
813 /* Frees everything associated with the current statement. */
816 undo_new_statement (void)
818 gfc_free_statements (new_st
.block
);
819 gfc_free_statements (new_st
.next
);
820 gfc_free_statement (&new_st
);
825 /* If the current statement has a statement label, make sure that it
826 is allowed to, or should have one. */
829 check_statement_label (gfc_statement st
)
833 if (gfc_statement_label
== NULL
)
836 gfc_error ("FORMAT statement at %L does not have a statement label",
844 case ST_END_FUNCTION
:
845 case ST_END_SUBROUTINE
:
851 type
= ST_LABEL_TARGET
;
855 type
= ST_LABEL_FORMAT
;
858 /* Statement labels are not restricted from appearing on a
859 particular line. However, there are plenty of situations
860 where the resulting label can't be referenced. */
863 type
= ST_LABEL_BAD_TARGET
;
867 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
869 new_st
.here
= gfc_statement_label
;
873 /* Figures out what the enclosing program unit is. This will be a
874 function, subroutine, program, block data or module. */
877 gfc_enclosing_unit (gfc_compile_state
* result
)
881 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
882 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
883 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
884 || p
->state
== COMP_PROGRAM
)
893 *result
= COMP_PROGRAM
;
898 /* Translate a statement enum to a string. */
901 gfc_ascii_statement (gfc_statement st
)
907 case ST_ARITHMETIC_IF
:
908 p
= _("arithmetic IF");
914 p
= _("attribute declaration");
944 p
= _("data declaration");
952 case ST_DERIVED_DECL
:
953 p
= _("derived type declaration");
967 case ST_END_BLOCK_DATA
:
968 p
= "END BLOCK DATA";
979 case ST_END_FUNCTION
:
985 case ST_END_INTERFACE
:
997 case ST_END_SUBROUTINE
:
998 p
= "END SUBROUTINE";
1009 case ST_EQUIVALENCE
:
1018 case ST_FORALL_BLOCK
: /* Fall through */
1037 case ST_IMPLICIT_NONE
:
1038 p
= "IMPLICIT NONE";
1040 case ST_IMPLIED_ENDDO
:
1041 p
= _("implied END DO");
1067 case ST_MODULE_PROC
:
1068 p
= "MODULE PROCEDURE";
1103 case ST_WHERE_BLOCK
: /* Fall through */
1111 p
= _("assignment");
1113 case ST_POINTER_ASSIGNMENT
:
1114 p
= _("pointer assignment");
1116 case ST_SELECT_CASE
:
1125 case ST_STATEMENT_FUNCTION
:
1126 p
= "STATEMENT FUNCTION";
1128 case ST_LABEL_ASSIGNMENT
:
1129 p
= "LABEL ASSIGNMENT";
1132 p
= "ENUM DEFINITION";
1135 p
= "ENUMERATOR DEFINITION";
1143 case ST_OMP_BARRIER
:
1144 p
= "!$OMP BARRIER";
1146 case ST_OMP_CRITICAL
:
1147 p
= "!$OMP CRITICAL";
1152 case ST_OMP_END_CRITICAL
:
1153 p
= "!$OMP END CRITICAL";
1158 case ST_OMP_END_MASTER
:
1159 p
= "!$OMP END MASTER";
1161 case ST_OMP_END_ORDERED
:
1162 p
= "!$OMP END ORDERED";
1164 case ST_OMP_END_PARALLEL
:
1165 p
= "!$OMP END PARALLEL";
1167 case ST_OMP_END_PARALLEL_DO
:
1168 p
= "!$OMP END PARALLEL DO";
1170 case ST_OMP_END_PARALLEL_SECTIONS
:
1171 p
= "!$OMP END PARALLEL SECTIONS";
1173 case ST_OMP_END_PARALLEL_WORKSHARE
:
1174 p
= "!$OMP END PARALLEL WORKSHARE";
1176 case ST_OMP_END_SECTIONS
:
1177 p
= "!$OMP END SECTIONS";
1179 case ST_OMP_END_SINGLE
:
1180 p
= "!$OMP END SINGLE";
1182 case ST_OMP_END_WORKSHARE
:
1183 p
= "!$OMP END WORKSHARE";
1191 case ST_OMP_ORDERED
:
1192 p
= "!$OMP ORDERED";
1194 case ST_OMP_PARALLEL
:
1195 p
= "!$OMP PARALLEL";
1197 case ST_OMP_PARALLEL_DO
:
1198 p
= "!$OMP PARALLEL DO";
1200 case ST_OMP_PARALLEL_SECTIONS
:
1201 p
= "!$OMP PARALLEL SECTIONS";
1203 case ST_OMP_PARALLEL_WORKSHARE
:
1204 p
= "!$OMP PARALLEL WORKSHARE";
1206 case ST_OMP_SECTIONS
:
1207 p
= "!$OMP SECTIONS";
1209 case ST_OMP_SECTION
:
1210 p
= "!$OMP SECTION";
1215 case ST_OMP_THREADPRIVATE
:
1216 p
= "!$OMP THREADPRIVATE";
1218 case ST_OMP_WORKSHARE
:
1219 p
= "!$OMP WORKSHARE";
1222 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1229 /* Create a symbol for the main program and assign it to ns->proc_name. */
1232 main_program_symbol (gfc_namespace
* ns
)
1234 gfc_symbol
*main_program
;
1235 symbol_attribute attr
;
1237 gfc_get_symbol ("MAIN__", ns
, &main_program
);
1238 gfc_clear_attr (&attr
);
1239 attr
.flavor
= FL_PROCEDURE
;
1240 attr
.proc
= PROC_UNKNOWN
;
1241 attr
.subroutine
= 1;
1242 attr
.access
= ACCESS_PUBLIC
;
1243 attr
.is_main_program
= 1;
1244 main_program
->attr
= attr
;
1245 main_program
->declared_at
= gfc_current_locus
;
1246 ns
->proc_name
= main_program
;
1247 gfc_commit_symbols ();
1251 /* Do whatever is necessary to accept the last statement. */
1254 accept_statement (gfc_statement st
)
1263 case ST_IMPLICIT_NONE
:
1264 gfc_set_implicit_none ();
1273 gfc_current_ns
->proc_name
= gfc_new_block
;
1276 /* If the statement is the end of a block, lay down a special code
1277 that allows a branch to the end of the block from within the
1282 if (gfc_statement_label
!= NULL
)
1284 new_st
.op
= EXEC_NOP
;
1290 /* The end-of-program unit statements do not get the special
1291 marker and require a statement of some sort if they are a
1294 case ST_END_PROGRAM
:
1295 case ST_END_FUNCTION
:
1296 case ST_END_SUBROUTINE
:
1297 if (gfc_statement_label
!= NULL
)
1299 new_st
.op
= EXEC_RETURN
;
1315 gfc_commit_symbols ();
1316 gfc_warning_check ();
1317 gfc_clear_new_st ();
1321 /* Undo anything tentative that has been built for the current
1325 reject_statement (void)
1327 gfc_new_block
= NULL
;
1328 gfc_undo_symbols ();
1329 gfc_clear_warning ();
1330 undo_new_statement ();
1334 /* Generic complaint about an out of order statement. We also do
1335 whatever is necessary to clean up. */
1338 unexpected_statement (gfc_statement st
)
1341 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1343 reject_statement ();
1347 /* Given the next statement seen by the matcher, make sure that it is
1348 in proper order with the last. This subroutine is initialized by
1349 calling it with an argument of ST_NONE. If there is a problem, we
1350 issue an error and return FAILURE. Otherwise we return SUCCESS.
1352 Individual parsers need to verify that the statements seen are
1353 valid before calling here, ie ENTRY statements are not allowed in
1354 INTERFACE blocks. The following diagram is taken from the standard:
1356 +---------------------------------------+
1357 | program subroutine function module |
1358 +---------------------------------------+
1360 +---------------------------------------+
1362 +---------------------------------------+
1364 | +-----------+------------------+
1365 | | parameter | implicit |
1366 | +-----------+------------------+
1367 | format | | derived type |
1368 | entry | parameter | interface |
1369 | | data | specification |
1370 | | | statement func |
1371 | +-----------+------------------+
1372 | | data | executable |
1373 +--------+-----------+------------------+
1375 +---------------------------------------+
1376 | internal module/subprogram |
1377 +---------------------------------------+
1379 +---------------------------------------+
1386 { ORDER_START
, ORDER_USE
, ORDER_IMPORT
, ORDER_IMPLICIT_NONE
,
1387 ORDER_IMPLICIT
, ORDER_SPEC
, ORDER_EXEC
1390 gfc_statement last_statement
;
1396 verify_st_order (st_state
* p
, gfc_statement st
)
1402 p
->state
= ORDER_START
;
1406 if (p
->state
> ORDER_USE
)
1408 p
->state
= ORDER_USE
;
1412 if (p
->state
> ORDER_IMPORT
)
1414 p
->state
= ORDER_IMPORT
;
1417 case ST_IMPLICIT_NONE
:
1418 if (p
->state
> ORDER_IMPLICIT_NONE
)
1421 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1422 statement disqualifies a USE but not an IMPLICIT NONE.
1423 Duplicate IMPLICIT NONEs are caught when the implicit types
1426 p
->state
= ORDER_IMPLICIT_NONE
;
1430 if (p
->state
> ORDER_IMPLICIT
)
1432 p
->state
= ORDER_IMPLICIT
;
1437 if (p
->state
< ORDER_IMPLICIT_NONE
)
1438 p
->state
= ORDER_IMPLICIT_NONE
;
1442 if (p
->state
>= ORDER_EXEC
)
1444 if (p
->state
< ORDER_IMPLICIT
)
1445 p
->state
= ORDER_IMPLICIT
;
1449 if (p
->state
< ORDER_SPEC
)
1450 p
->state
= ORDER_SPEC
;
1455 case ST_DERIVED_DECL
:
1457 if (p
->state
>= ORDER_EXEC
)
1459 if (p
->state
< ORDER_SPEC
)
1460 p
->state
= ORDER_SPEC
;
1465 if (p
->state
< ORDER_EXEC
)
1466 p
->state
= ORDER_EXEC
;
1471 ("Unexpected %s statement in verify_st_order() at %C",
1472 gfc_ascii_statement (st
));
1475 /* All is well, record the statement in case we need it next time. */
1476 p
->where
= gfc_current_locus
;
1477 p
->last_statement
= st
;
1481 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1482 gfc_ascii_statement (st
),
1483 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1489 /* Handle an unexpected end of file. This is a show-stopper... */
1491 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1494 unexpected_eof (void)
1498 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1500 /* Memory cleanup. Move to "second to last". */
1501 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1504 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1507 longjmp (eof_buf
, 1);
1511 /* Parse a derived type. */
1514 parse_derived (void)
1516 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1524 accept_statement (ST_DERIVED_DECL
);
1525 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1527 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1534 while (compiling_type
)
1536 st
= next_statement ();
1543 accept_statement (st
);
1550 if (!seen_component
)
1552 gfc_error ("Derived type definition at %C has no components");
1556 accept_statement (ST_END_TYPE
);
1560 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1563 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1570 gfc_error ("PRIVATE statement at %C must precede "
1571 "structure components");
1578 gfc_error ("Duplicate PRIVATE statement at %C");
1582 s
.sym
->component_access
= ACCESS_PRIVATE
;
1583 accept_statement (ST_PRIVATE
);
1590 gfc_error ("SEQUENCE statement at %C must precede "
1591 "structure components");
1596 if (gfc_current_block ()->attr
.sequence
)
1597 gfc_warning ("SEQUENCE attribute at %C already specified in "
1602 gfc_error ("Duplicate SEQUENCE statement at %C");
1607 gfc_add_sequence (&gfc_current_block ()->attr
,
1608 gfc_current_block ()->name
, NULL
);
1612 unexpected_statement (st
);
1617 /* Look for allocatable components. */
1618 sym
= gfc_current_block ();
1619 for (c
= sym
->components
; c
; c
= c
->next
)
1621 if (c
->allocatable
|| (c
->ts
.type
== BT_DERIVED
1622 && c
->ts
.derived
->attr
.alloc_comp
))
1624 sym
->attr
.alloc_comp
= 1;
1634 /* Parse an ENUM. */
1643 int seen_enumerator
= 0;
1647 push_state (&s
, COMP_ENUM
, gfc_new_block
);
1651 while (compiling_enum
)
1653 st
= next_statement ();
1661 seen_enumerator
= 1;
1662 accept_statement (st
);
1667 if (!seen_enumerator
)
1669 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1672 accept_statement (st
);
1676 gfc_free_enum_history ();
1677 unexpected_statement (st
);
1684 /* Parse an interface. We must be able to deal with the possibility
1685 of recursive interfaces. The parse_spec() subroutine is mutually
1686 recursive with parse_interface(). */
1688 static gfc_statement
parse_spec (gfc_statement
);
1691 parse_interface (void)
1693 gfc_compile_state new_state
, current_state
;
1694 gfc_symbol
*prog_unit
, *sym
;
1695 gfc_interface_info save
;
1696 gfc_state_data s1
, s2
;
1700 accept_statement (ST_INTERFACE
);
1702 current_interface
.ns
= gfc_current_ns
;
1703 save
= current_interface
;
1705 sym
= (current_interface
.type
== INTERFACE_GENERIC
1706 || current_interface
.type
== INTERFACE_USER_OP
) ? gfc_new_block
: NULL
;
1708 push_state (&s1
, COMP_INTERFACE
, sym
);
1709 current_state
= COMP_NONE
;
1712 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1714 st
= next_statement ();
1721 new_state
= COMP_SUBROUTINE
;
1722 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1723 gfc_new_block
->formal
, NULL
);
1727 new_state
= COMP_FUNCTION
;
1728 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1729 gfc_new_block
->formal
, NULL
);
1732 case ST_MODULE_PROC
: /* The module procedure matcher makes
1733 sure the context is correct. */
1734 accept_statement (st
);
1735 gfc_free_namespace (gfc_current_ns
);
1738 case ST_END_INTERFACE
:
1739 gfc_free_namespace (gfc_current_ns
);
1740 gfc_current_ns
= current_interface
.ns
;
1744 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1745 gfc_ascii_statement (st
));
1746 reject_statement ();
1747 gfc_free_namespace (gfc_current_ns
);
1752 /* Make sure that a generic interface has only subroutines or
1753 functions and that the generic name has the right attribute. */
1754 if (current_interface
.type
== INTERFACE_GENERIC
)
1756 if (current_state
== COMP_NONE
)
1758 if (new_state
== COMP_FUNCTION
)
1759 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1760 else if (new_state
== COMP_SUBROUTINE
)
1761 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1763 current_state
= new_state
;
1767 if (new_state
!= current_state
)
1769 if (new_state
== COMP_SUBROUTINE
)
1771 ("SUBROUTINE at %C does not belong in a generic function "
1774 if (new_state
== COMP_FUNCTION
)
1776 ("FUNCTION at %C does not belong in a generic subroutine "
1782 push_state (&s2
, new_state
, gfc_new_block
);
1783 accept_statement (st
);
1784 prog_unit
= gfc_new_block
;
1785 prog_unit
->formal_ns
= gfc_current_ns
;
1786 proc_locus
= gfc_current_locus
;
1789 /* Read data declaration statements. */
1790 st
= parse_spec (ST_NONE
);
1792 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1794 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1795 gfc_ascii_statement (st
));
1796 reject_statement ();
1800 current_interface
= save
;
1801 gfc_add_interface (prog_unit
);
1804 if (current_interface
.ns
1805 && current_interface
.ns
->proc_name
1806 && strcmp (current_interface
.ns
->proc_name
->name
,
1807 prog_unit
->name
) == 0)
1808 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1809 "enclosing procedure", prog_unit
->name
, &proc_locus
);
1818 /* Parse a set of specification statements. Returns the statement
1819 that doesn't fit. */
1821 static gfc_statement
1822 parse_spec (gfc_statement st
)
1826 verify_st_order (&ss
, ST_NONE
);
1828 st
= next_statement ();
1838 case ST_DATA
: /* Not allowed in interfaces */
1839 if (gfc_current_state () == COMP_INTERFACE
)
1846 case ST_IMPLICIT_NONE
:
1851 case ST_DERIVED_DECL
:
1853 if (verify_st_order (&ss
, st
) == FAILURE
)
1855 reject_statement ();
1856 st
= next_statement ();
1866 case ST_DERIVED_DECL
:
1872 if (gfc_current_state () != COMP_MODULE
)
1874 gfc_error ("%s statement must appear in a MODULE",
1875 gfc_ascii_statement (st
));
1879 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1881 gfc_error ("%s statement at %C follows another accessibility "
1882 "specification", gfc_ascii_statement (st
));
1886 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1887 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1895 accept_statement (st
);
1896 st
= next_statement ();
1900 accept_statement (st
);
1902 st
= next_statement ();
1913 /* Parse a WHERE block, (not a simple WHERE statement). */
1916 parse_where_block (void)
1918 int seen_empty_else
;
1923 accept_statement (ST_WHERE_BLOCK
);
1924 top
= gfc_state_stack
->tail
;
1926 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1928 d
= add_statement ();
1929 d
->expr
= top
->expr
;
1935 seen_empty_else
= 0;
1939 st
= next_statement ();
1945 case ST_WHERE_BLOCK
:
1946 parse_where_block ();
1951 accept_statement (st
);
1955 if (seen_empty_else
)
1958 ("ELSEWHERE statement at %C follows previous unmasked "
1963 if (new_st
.expr
== NULL
)
1964 seen_empty_else
= 1;
1966 d
= new_level (gfc_state_stack
->head
);
1968 d
->expr
= new_st
.expr
;
1970 accept_statement (st
);
1975 accept_statement (st
);
1979 gfc_error ("Unexpected %s statement in WHERE block at %C",
1980 gfc_ascii_statement (st
));
1981 reject_statement ();
1986 while (st
!= ST_END_WHERE
);
1992 /* Parse a FORALL block (not a simple FORALL statement). */
1995 parse_forall_block (void)
2001 accept_statement (ST_FORALL_BLOCK
);
2002 top
= gfc_state_stack
->tail
;
2004 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2006 d
= add_statement ();
2007 d
->op
= EXEC_FORALL
;
2012 st
= next_statement ();
2017 case ST_POINTER_ASSIGNMENT
:
2020 accept_statement (st
);
2023 case ST_WHERE_BLOCK
:
2024 parse_where_block ();
2027 case ST_FORALL_BLOCK
:
2028 parse_forall_block ();
2032 accept_statement (st
);
2039 gfc_error ("Unexpected %s statement in FORALL block at %C",
2040 gfc_ascii_statement (st
));
2042 reject_statement ();
2046 while (st
!= ST_END_FORALL
);
2052 static gfc_statement
parse_executable (gfc_statement
);
2054 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2057 parse_if_block (void)
2066 accept_statement (ST_IF_BLOCK
);
2068 top
= gfc_state_stack
->tail
;
2069 push_state (&s
, COMP_IF
, gfc_new_block
);
2071 new_st
.op
= EXEC_IF
;
2072 d
= add_statement ();
2074 d
->expr
= top
->expr
;
2080 st
= parse_executable (ST_NONE
);
2091 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
2094 reject_statement ();
2098 d
= new_level (gfc_state_stack
->head
);
2100 d
->expr
= new_st
.expr
;
2102 accept_statement (st
);
2109 gfc_error ("Duplicate ELSE statements at %L and %C",
2111 reject_statement ();
2116 else_locus
= gfc_current_locus
;
2118 d
= new_level (gfc_state_stack
->head
);
2121 accept_statement (st
);
2129 unexpected_statement (st
);
2133 while (st
!= ST_ENDIF
);
2136 accept_statement (st
);
2140 /* Parse a SELECT block. */
2143 parse_select_block (void)
2149 accept_statement (ST_SELECT_CASE
);
2151 cp
= gfc_state_stack
->tail
;
2152 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2154 /* Make sure that the next statement is a CASE or END SELECT. */
2157 st
= next_statement ();
2160 if (st
== ST_END_SELECT
)
2162 /* Empty SELECT CASE is OK. */
2163 accept_statement (st
);
2171 ("Expected a CASE or END SELECT statement following SELECT CASE "
2174 reject_statement ();
2177 /* At this point, we're got a nonempty select block. */
2178 cp
= new_level (cp
);
2181 accept_statement (st
);
2185 st
= parse_executable (ST_NONE
);
2192 cp
= new_level (gfc_state_stack
->head
);
2194 gfc_clear_new_st ();
2196 accept_statement (st
);
2202 /* Can't have an executable statement because of
2203 parse_executable(). */
2205 unexpected_statement (st
);
2209 while (st
!= ST_END_SELECT
);
2212 accept_statement (st
);
2216 /* Given a symbol, make sure it is not an iteration variable for a DO
2217 statement. This subroutine is called when the symbol is seen in a
2218 context that causes it to become redefined. If the symbol is an
2219 iterator, we generate an error message and return nonzero. */
2222 gfc_check_do_variable (gfc_symtree
*st
)
2226 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2227 if (s
->do_variable
== st
)
2229 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2230 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2238 /* Checks to see if the current statement label closes an enddo.
2239 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2240 an error) if it incorrectly closes an ENDDO. */
2243 check_do_closure (void)
2247 if (gfc_statement_label
== NULL
)
2250 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2251 if (p
->state
== COMP_DO
)
2255 return 0; /* No loops to close */
2257 if (p
->ext
.end_do_label
== gfc_statement_label
)
2260 if (p
== gfc_state_stack
)
2264 ("End of nonblock DO statement at %C is within another block");
2268 /* At this point, the label doesn't terminate the innermost loop.
2269 Make sure it doesn't terminate another one. */
2270 for (; p
; p
= p
->previous
)
2271 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
2273 gfc_error ("End of nonblock DO statement at %C is interwoven "
2274 "with another DO loop");
2282 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2283 handled inside of parse_executable(), because they aren't really
2287 parse_do_block (void)
2294 s
.ext
.end_do_label
= new_st
.label
;
2296 if (new_st
.ext
.iterator
!= NULL
)
2297 stree
= new_st
.ext
.iterator
->var
->symtree
;
2301 accept_statement (ST_DO
);
2303 top
= gfc_state_stack
->tail
;
2304 push_state (&s
, COMP_DO
, gfc_new_block
);
2306 s
.do_variable
= stree
;
2308 top
->block
= new_level (top
);
2309 top
->block
->op
= EXEC_DO
;
2312 st
= parse_executable (ST_NONE
);
2320 if (s
.ext
.end_do_label
!= NULL
2321 && s
.ext
.end_do_label
!= gfc_statement_label
)
2323 ("Statement label in ENDDO at %C doesn't match DO label");
2325 if (gfc_statement_label
!= NULL
)
2327 new_st
.op
= EXEC_NOP
;
2332 case ST_IMPLIED_ENDDO
:
2333 /* If the do-stmt of this DO construct has a do-construct-name,
2334 the corresponding end-do must be an end-do-stmt (with a matching
2335 name, but in that case we must have seen ST_ENDDO first).
2336 We only complain about this in pedantic mode. */
2337 if (gfc_current_block () != NULL
)
2339 ("named block DO at %L requires matching ENDDO name",
2340 &gfc_current_block()->declared_at
);
2345 unexpected_statement (st
);
2350 accept_statement (st
);
2354 /* Parse the statements of OpenMP do/parallel do. */
2356 static gfc_statement
2357 parse_omp_do (gfc_statement omp_st
)
2363 accept_statement (omp_st
);
2365 cp
= gfc_state_stack
->tail
;
2366 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2367 np
= new_level (cp
);
2373 st
= next_statement ();
2376 else if (st
== ST_DO
)
2379 unexpected_statement (st
);
2383 if (gfc_statement_label
!= NULL
2384 && gfc_state_stack
->previous
!= NULL
2385 && gfc_state_stack
->previous
->state
== COMP_DO
2386 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
2394 there should be no !$OMP END DO. */
2396 return ST_IMPLIED_ENDDO
;
2399 check_do_closure ();
2402 st
= next_statement ();
2403 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
2405 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
2406 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2408 gcc_assert (new_st
.op
== EXEC_NOP
);
2409 gfc_clear_new_st ();
2410 gfc_commit_symbols ();
2411 gfc_warning_check ();
2412 st
= next_statement ();
2418 /* Parse the statements of OpenMP atomic directive. */
2421 parse_omp_atomic (void)
2427 accept_statement (ST_OMP_ATOMIC
);
2429 cp
= gfc_state_stack
->tail
;
2430 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2431 np
= new_level (cp
);
2437 st
= next_statement ();
2440 else if (st
== ST_ASSIGNMENT
)
2443 unexpected_statement (st
);
2446 accept_statement (st
);
2452 /* Parse the statements of an OpenMP structured block. */
2455 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
2457 gfc_statement st
, omp_end_st
;
2461 accept_statement (omp_st
);
2463 cp
= gfc_state_stack
->tail
;
2464 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2465 np
= new_level (cp
);
2471 case ST_OMP_PARALLEL
:
2472 omp_end_st
= ST_OMP_END_PARALLEL
;
2474 case ST_OMP_PARALLEL_SECTIONS
:
2475 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
2477 case ST_OMP_SECTIONS
:
2478 omp_end_st
= ST_OMP_END_SECTIONS
;
2480 case ST_OMP_ORDERED
:
2481 omp_end_st
= ST_OMP_END_ORDERED
;
2483 case ST_OMP_CRITICAL
:
2484 omp_end_st
= ST_OMP_END_CRITICAL
;
2487 omp_end_st
= ST_OMP_END_MASTER
;
2490 omp_end_st
= ST_OMP_END_SINGLE
;
2492 case ST_OMP_WORKSHARE
:
2493 omp_end_st
= ST_OMP_END_WORKSHARE
;
2495 case ST_OMP_PARALLEL_WORKSHARE
:
2496 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
2504 if (workshare_stmts_only
)
2506 /* Inside of !$omp workshare, only
2509 where statements and constructs
2510 forall statements and constructs
2514 are allowed. For !$omp critical these
2515 restrictions apply recursively. */
2518 st
= next_statement ();
2529 accept_statement (st
);
2532 case ST_WHERE_BLOCK
:
2533 parse_where_block ();
2536 case ST_FORALL_BLOCK
:
2537 parse_forall_block ();
2540 case ST_OMP_PARALLEL
:
2541 case ST_OMP_PARALLEL_SECTIONS
:
2542 parse_omp_structured_block (st
, false);
2545 case ST_OMP_PARALLEL_WORKSHARE
:
2546 case ST_OMP_CRITICAL
:
2547 parse_omp_structured_block (st
, true);
2550 case ST_OMP_PARALLEL_DO
:
2551 st
= parse_omp_do (st
);
2555 parse_omp_atomic ();
2566 st
= next_statement ();
2570 st
= parse_executable (ST_NONE
);
2573 else if (st
== ST_OMP_SECTION
2574 && (omp_st
== ST_OMP_SECTIONS
2575 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
2577 np
= new_level (np
);
2581 else if (st
!= omp_end_st
)
2582 unexpected_statement (st
);
2584 while (st
!= omp_end_st
);
2588 case EXEC_OMP_END_NOWAIT
:
2589 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2591 case EXEC_OMP_CRITICAL
:
2592 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
2593 || (new_st
.ext
.omp_name
!= NULL
2594 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
2595 gfc_error ("Name after !$omp critical and !$omp end critical does"
2596 " not match at %C");
2597 gfc_free ((char *) new_st
.ext
.omp_name
);
2599 case EXEC_OMP_END_SINGLE
:
2600 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
2601 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
2602 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
2603 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
2611 gfc_clear_new_st ();
2612 gfc_commit_symbols ();
2613 gfc_warning_check ();
2618 /* Accept a series of executable statements. We return the first
2619 statement that doesn't fit to the caller. Any block statements are
2620 passed on to the correct handler, which usually passes the buck
2623 static gfc_statement
2624 parse_executable (gfc_statement st
)
2629 st
= next_statement ();
2633 close_flag
= check_do_closure ();
2638 case ST_END_PROGRAM
:
2641 case ST_END_FUNCTION
:
2645 case ST_END_SUBROUTINE
:
2650 case ST_SELECT_CASE
:
2652 ("%s statement at %C cannot terminate a non-block DO loop",
2653 gfc_ascii_statement (st
));
2669 accept_statement (st
);
2670 if (close_flag
== 1)
2671 return ST_IMPLIED_ENDDO
;
2678 case ST_SELECT_CASE
:
2679 parse_select_block ();
2684 if (check_do_closure () == 1)
2685 return ST_IMPLIED_ENDDO
;
2688 case ST_WHERE_BLOCK
:
2689 parse_where_block ();
2692 case ST_FORALL_BLOCK
:
2693 parse_forall_block ();
2696 case ST_OMP_PARALLEL
:
2697 case ST_OMP_PARALLEL_SECTIONS
:
2698 case ST_OMP_SECTIONS
:
2699 case ST_OMP_ORDERED
:
2700 case ST_OMP_CRITICAL
:
2703 parse_omp_structured_block (st
, false);
2706 case ST_OMP_WORKSHARE
:
2707 case ST_OMP_PARALLEL_WORKSHARE
:
2708 parse_omp_structured_block (st
, true);
2712 case ST_OMP_PARALLEL_DO
:
2713 st
= parse_omp_do (st
);
2714 if (st
== ST_IMPLIED_ENDDO
)
2719 parse_omp_atomic ();
2726 st
= next_statement ();
2731 /* Parse a series of contained program units. */
2733 static void parse_progunit (gfc_statement
);
2736 /* Fix the symbols for sibling functions. These are incorrectly added to
2737 the child namespace as the parser didn't know about this procedure. */
2740 gfc_fixup_sibling_symbols (gfc_symbol
* sym
, gfc_namespace
* siblings
)
2744 gfc_symbol
*old_sym
;
2746 sym
->attr
.referenced
= 1;
2747 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2749 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2751 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
2754 old_sym
= st
->n
.sym
;
2755 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2756 || old_sym
->ts
.type
== BT_UNKNOWN
)
2757 && old_sym
->ns
== ns
2758 && ! old_sym
->attr
.contained
)
2760 /* Replace it with the symbol from the parent namespace. */
2764 /* Free the old (local) symbol. */
2766 if (old_sym
->refs
== 0)
2767 gfc_free_symbol (old_sym
);
2770 /* Do the same for any contained procedures. */
2771 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2776 parse_contained (int module
)
2778 gfc_namespace
*ns
, *parent_ns
;
2779 gfc_state_data s1
, s2
;
2783 int contains_statements
= 0;
2785 push_state (&s1
, COMP_CONTAINS
, NULL
);
2786 parent_ns
= gfc_current_ns
;
2790 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
2792 gfc_current_ns
->sibling
= parent_ns
->contained
;
2793 parent_ns
->contained
= gfc_current_ns
;
2795 st
= next_statement ();
2804 contains_statements
= 1;
2805 accept_statement (st
);
2808 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2811 /* For internal procedures, create/update the symbol in the
2812 parent namespace. */
2816 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2818 ("Contained procedure '%s' at %C is already ambiguous",
2819 gfc_new_block
->name
);
2822 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
2823 &gfc_new_block
->declared_at
) ==
2826 if (st
== ST_FUNCTION
)
2827 gfc_add_function (&sym
->attr
, sym
->name
,
2828 &gfc_new_block
->declared_at
);
2830 gfc_add_subroutine (&sym
->attr
, sym
->name
,
2831 &gfc_new_block
->declared_at
);
2835 gfc_commit_symbols ();
2838 sym
= gfc_new_block
;
2840 /* Mark this as a contained function, so it isn't replaced
2841 by other module functions. */
2842 sym
->attr
.contained
= 1;
2843 sym
->attr
.referenced
= 1;
2845 parse_progunit (ST_NONE
);
2847 /* Fix up any sibling functions that refer to this one. */
2848 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2849 /* Or refer to any of its alternate entry points. */
2850 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2851 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2853 gfc_current_ns
->code
= s2
.head
;
2854 gfc_current_ns
= parent_ns
;
2859 /* These statements are associated with the end of the host
2861 case ST_END_FUNCTION
:
2863 case ST_END_PROGRAM
:
2864 case ST_END_SUBROUTINE
:
2865 accept_statement (st
);
2869 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2870 gfc_ascii_statement (st
));
2871 reject_statement ();
2875 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2876 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2878 /* The first namespace in the list is guaranteed to not have
2879 anything (worthwhile) in it. */
2881 gfc_current_ns
= parent_ns
;
2883 ns
= gfc_current_ns
->contained
;
2884 gfc_current_ns
->contained
= ns
->sibling
;
2885 gfc_free_namespace (ns
);
2888 if (!contains_statements
)
2889 /* This is valid in Fortran 2008. */
2890 gfc_notify_std (GFC_STD_GNU
, "Extension: "
2891 "CONTAINS statement without FUNCTION "
2892 "or SUBROUTINE statement at %C");
2896 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2899 parse_progunit (gfc_statement st
)
2904 st
= parse_spec (st
);
2914 accept_statement (st
);
2924 st
= parse_executable (st
);
2935 accept_statement (st
);
2942 unexpected_statement (st
);
2943 reject_statement ();
2944 st
= next_statement ();
2950 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2951 if (p
->state
== COMP_CONTAINS
)
2954 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2959 gfc_error ("CONTAINS statement at %C is already in a contained "
2961 st
= next_statement ();
2965 parse_contained (0);
2968 gfc_current_ns
->code
= gfc_state_stack
->head
;
2972 /* Come here to complain about a global symbol already in use as
2976 global_used (gfc_gsymbol
*sym
, locus
*where
)
2981 where
= &gfc_current_locus
;
2991 case GSYM_SUBROUTINE
:
2992 name
= "SUBROUTINE";
2997 case GSYM_BLOCK_DATA
:
2998 name
= "BLOCK DATA";
3004 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3008 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3009 sym
->name
, where
, name
, &sym
->where
);
3013 /* Parse a block data program unit. */
3016 parse_block_data (void)
3019 static locus blank_locus
;
3020 static int blank_block
=0;
3023 gfc_current_ns
->proc_name
= gfc_new_block
;
3024 gfc_current_ns
->is_block_data
= 1;
3026 if (gfc_new_block
== NULL
)
3029 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3030 "prior BLOCK DATA at %L", &blank_locus
);
3034 blank_locus
= gfc_current_locus
;
3039 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3040 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3041 global_used(s
, NULL
);
3044 s
->type
= GSYM_BLOCK_DATA
;
3045 s
->where
= gfc_current_locus
;
3050 st
= parse_spec (ST_NONE
);
3052 while (st
!= ST_END_BLOCK_DATA
)
3054 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3055 gfc_ascii_statement (st
));
3056 reject_statement ();
3057 st
= next_statement ();
3062 /* Parse a module subprogram. */
3070 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3071 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3072 global_used(s
, NULL
);
3075 s
->type
= GSYM_MODULE
;
3076 s
->where
= gfc_current_locus
;
3080 st
= parse_spec (ST_NONE
);
3089 parse_contained (1);
3093 accept_statement (st
);
3097 gfc_error ("Unexpected %s statement in MODULE at %C",
3098 gfc_ascii_statement (st
));
3100 reject_statement ();
3101 st
= next_statement ();
3107 /* Add a procedure name to the global symbol table. */
3110 add_global_procedure (int sub
)
3114 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3117 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3118 global_used(s
, NULL
);
3121 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3122 s
->where
= gfc_current_locus
;
3128 /* Add a program to the global symbol table. */
3131 add_global_program (void)
3135 if (gfc_new_block
== NULL
)
3137 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3139 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
3140 global_used(s
, NULL
);
3143 s
->type
= GSYM_PROGRAM
;
3144 s
->where
= gfc_current_locus
;
3150 /* Top level parser. */
3153 gfc_parse_file (void)
3155 int seen_program
, errors_before
, errors
;
3156 gfc_state_data top
, s
;
3160 top
.state
= COMP_NONE
;
3162 top
.previous
= NULL
;
3163 top
.head
= top
.tail
= NULL
;
3164 top
.do_variable
= NULL
;
3166 gfc_state_stack
= &top
;
3168 gfc_clear_new_st ();
3170 gfc_statement_label
= NULL
;
3172 if (setjmp (eof_buf
))
3173 return FAILURE
; /* Come here on unexpected EOF */
3177 /* Exit early for empty files. */
3183 st
= next_statement ();
3192 goto duplicate_main
;
3194 prog_locus
= gfc_current_locus
;
3196 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3197 main_program_symbol(gfc_current_ns
);
3198 accept_statement (st
);
3199 add_global_program ();
3200 parse_progunit (ST_NONE
);
3204 add_global_procedure (1);
3205 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
3206 accept_statement (st
);
3207 parse_progunit (ST_NONE
);
3211 add_global_procedure (0);
3212 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
3213 accept_statement (st
);
3214 parse_progunit (ST_NONE
);
3218 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
3219 accept_statement (st
);
3220 parse_block_data ();
3224 push_state (&s
, COMP_MODULE
, gfc_new_block
);
3225 accept_statement (st
);
3227 gfc_get_errors (NULL
, &errors_before
);
3231 /* Anything else starts a nameless main program block. */
3234 goto duplicate_main
;
3236 prog_locus
= gfc_current_locus
;
3238 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3239 main_program_symbol(gfc_current_ns
);
3240 parse_progunit (st
);
3244 gfc_current_ns
->code
= s
.head
;
3246 gfc_resolve (gfc_current_ns
);
3248 /* Dump the parse tree if requested. */
3249 if (gfc_option
.verbose
)
3250 gfc_show_namespace (gfc_current_ns
);
3252 gfc_get_errors (NULL
, &errors
);
3253 if (s
.state
== COMP_MODULE
)
3255 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
3257 gfc_generate_module_code (gfc_current_ns
);
3262 gfc_generate_code (gfc_current_ns
);
3273 /* If we see a duplicate main program, shut down. If the second
3274 instance is an implied main program, ie data decls or executable
3275 statements, we're in for lots of errors. */
3276 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
3277 reject_statement ();