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 3, 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 COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 /* Current statement label. Zero means no statement label. Because new_st
30 can get wiped during statement matching, we have to keep it separate. */
32 gfc_st_label
*gfc_statement_label
;
34 static locus label_locus
;
35 static jmp_buf eof_buf
;
37 gfc_state_data
*gfc_state_stack
;
39 /* TODO: Re-order functions to kill these forward decls. */
40 static void check_statement_label (gfc_statement
);
41 static void undo_new_statement (void);
42 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 ("abstract% interface", gfc_match_abstract_interface
,
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
);
185 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
189 match ("call", gfc_match_call
, ST_CALL
);
190 match ("close", gfc_match_close
, ST_CLOSE
);
191 match ("continue", gfc_match_continue
, ST_CONTINUE
);
192 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
193 match ("case", gfc_match_case
, ST_CASE
);
194 match ("common", gfc_match_common
, ST_COMMON
);
195 match ("contains", gfc_match_eos
, ST_CONTAINS
);
199 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
200 match ("data", gfc_match_data
, ST_DATA
);
201 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
205 match ("end file", gfc_match_endfile
, ST_END_FILE
);
206 match ("exit", gfc_match_exit
, ST_EXIT
);
207 match ("else", gfc_match_else
, ST_ELSE
);
208 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
209 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
210 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
212 if (gfc_match_end (&st
) == MATCH_YES
)
215 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
216 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
217 match ("external", gfc_match_external
, ST_ATTR_DECL
);
221 match ("flush", gfc_match_flush
, ST_FLUSH
);
222 match ("format", gfc_match_format
, ST_FORMAT
);
226 match ("go to", gfc_match_goto
, ST_GOTO
);
230 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
231 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
232 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
233 match ("import", gfc_match_import
, ST_IMPORT
);
234 match ("interface", gfc_match_interface
, ST_INTERFACE
);
235 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
236 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
240 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
241 match ("module", gfc_match_module
, ST_MODULE
);
245 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
246 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
250 match ("open", gfc_match_open
, ST_OPEN
);
251 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
255 match ("print", gfc_match_print
, ST_WRITE
);
256 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
257 match ("pause", gfc_match_pause
, ST_PAUSE
);
258 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
259 if (gfc_match_private (&st
) == MATCH_YES
)
261 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
262 match ("program", gfc_match_program
, ST_PROGRAM
);
263 if (gfc_match_public (&st
) == MATCH_YES
)
265 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
269 match ("read", gfc_match_read
, ST_READ
);
270 match ("return", gfc_match_return
, ST_RETURN
);
271 match ("rewind", gfc_match_rewind
, ST_REWIND
);
275 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
276 match ("stop", gfc_match_stop
, ST_STOP
);
277 match ("save", gfc_match_save
, ST_ATTR_DECL
);
281 match ("target", gfc_match_target
, ST_ATTR_DECL
);
282 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
286 match ("use", gfc_match_use
, ST_USE
);
290 match ("value", gfc_match_value
, ST_ATTR_DECL
);
291 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
295 match ("write", gfc_match_write
, ST_WRITE
);
299 /* All else has failed, so give up. See if any of the matchers has
300 stored an error message of some sort. */
302 if (gfc_error_check () == 0)
303 gfc_error_now ("Unclassifiable statement at %C");
307 gfc_error_recovery ();
313 decode_omp_directive (void)
322 gfc_clear_error (); /* Clear any pending errors. */
323 gfc_clear_warning (); /* Clear any pending warnings. */
327 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
328 "or ELEMENTAL procedures");
329 gfc_error_recovery ();
333 old_locus
= gfc_current_locus
;
335 /* General OpenMP directive matching: Instead of testing every possible
336 statement, we eliminate most possibilities by peeking at the
339 c
= gfc_peek_char ();
344 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
347 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
350 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
353 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
356 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
357 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
358 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
359 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
360 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
361 match ("end parallel sections", gfc_match_omp_eos
,
362 ST_OMP_END_PARALLEL_SECTIONS
);
363 match ("end parallel workshare", gfc_match_omp_eos
,
364 ST_OMP_END_PARALLEL_WORKSHARE
);
365 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
366 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
367 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
368 match ("end workshare", gfc_match_omp_end_nowait
,
369 ST_OMP_END_WORKSHARE
);
372 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
375 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
378 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
381 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
382 match ("parallel sections", gfc_match_omp_parallel_sections
,
383 ST_OMP_PARALLEL_SECTIONS
);
384 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
385 ST_OMP_PARALLEL_WORKSHARE
);
386 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
389 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
390 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
391 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
394 match ("threadprivate", gfc_match_omp_threadprivate
,
395 ST_OMP_THREADPRIVATE
);
397 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
401 /* All else has failed, so give up. See if any of the matchers has
402 stored an error message of some sort. */
404 if (gfc_error_check () == 0)
405 gfc_error_now ("Unclassifiable OpenMP directive at %C");
409 gfc_error_recovery ();
417 /* Get the next statement in free form source. */
423 int c
, d
, cnt
, at_bol
;
425 at_bol
= gfc_at_bol ();
426 gfc_gobble_whitespace ();
428 c
= gfc_peek_char ();
432 /* Found a statement label? */
433 m
= gfc_match_st_label (&gfc_statement_label
);
435 d
= gfc_peek_char ();
436 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
438 gfc_match_small_literal_int (&c
, &cnt
);
441 gfc_error_now ("Too many digits in statement label at %C");
444 gfc_error_now ("Zero is not a valid statement label at %C");
447 c
= gfc_next_char ();
450 if (!gfc_is_whitespace (c
))
451 gfc_error_now ("Non-numeric character in statement label at %C");
457 label_locus
= gfc_current_locus
;
459 gfc_gobble_whitespace ();
461 if (at_bol
&& gfc_peek_char () == ';')
463 gfc_error_now ("Semicolon at %C needs to be preceded by "
465 gfc_next_char (); /* Eat up the semicolon. */
469 if (gfc_match_eos () == MATCH_YES
)
471 gfc_warning_now ("Ignoring statement label in empty statement "
473 gfc_free_st_label (gfc_statement_label
);
474 gfc_statement_label
= NULL
;
481 /* Comments have already been skipped by the time we get here,
482 except for OpenMP directives. */
483 if (gfc_option
.flag_openmp
)
487 c
= gfc_next_char ();
488 for (i
= 0; i
< 5; i
++, c
= gfc_next_char ())
489 gcc_assert (c
== "!$omp"[i
]);
491 gcc_assert (c
== ' ');
492 gfc_gobble_whitespace ();
493 return decode_omp_directive ();
497 if (at_bol
&& c
== ';')
499 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
500 gfc_next_char (); /* Eat up the semicolon. */
504 return decode_statement ();
508 /* Get the next statement in fixed-form source. */
513 int label
, digit_flag
, i
;
518 return decode_statement ();
520 /* Skip past the current label field, parsing a statement label if
521 one is there. This is a weird number parser, since the number is
522 contained within five columns and can have any kind of embedded
523 spaces. We also check for characters that make the rest of the
529 for (i
= 0; i
< 5; i
++)
531 c
= gfc_next_char_literal (0);
548 label
= label
* 10 + c
- '0';
549 label_locus
= gfc_current_locus
;
553 /* Comments have already been skipped by the time we get
554 here, except for OpenMP directives. */
556 if (gfc_option
.flag_openmp
)
558 for (i
= 0; i
< 5; i
++, c
= gfc_next_char_literal (0))
559 gcc_assert (TOLOWER (c
) == "*$omp"[i
]);
561 if (c
!= ' ' && c
!= '0')
563 gfc_buffer_error (0);
564 gfc_error ("Bad continuation line at %C");
568 return decode_omp_directive ();
572 /* Comments have already been skipped by the time we get
573 here so don't bother checking for them. */
576 gfc_buffer_error (0);
577 gfc_error ("Non-numeric character in statement label at %C");
585 gfc_warning_now ("Zero is not a valid statement label at %C");
588 /* We've found a valid statement label. */
589 gfc_statement_label
= gfc_get_st_label (label
);
593 /* Since this line starts a statement, it cannot be a continuation
594 of a previous statement. If we see something here besides a
595 space or zero, it must be a bad continuation line. */
597 c
= gfc_next_char_literal (0);
601 if (c
!= ' ' && c
!= '0')
603 gfc_buffer_error (0);
604 gfc_error ("Bad continuation line at %C");
608 /* Now that we've taken care of the statement label columns, we have
609 to make sure that the first nonblank character is not a '!'. If
610 it is, the rest of the line is a comment. */
614 loc
= gfc_current_locus
;
615 c
= gfc_next_char_literal (0);
617 while (gfc_is_whitespace (c
));
621 gfc_current_locus
= loc
;
625 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
629 if (gfc_match_eos () == MATCH_YES
)
632 /* At this point, we've got a nonblank statement to parse. */
633 return decode_statement ();
637 gfc_warning ("Ignoring statement label in empty statement at %C");
643 /* Return the next non-ST_NONE statement to the caller. We also worry
644 about including files and the ends of include files at this stage. */
647 next_statement (void)
651 gfc_new_block
= NULL
;
655 gfc_statement_label
= NULL
;
656 gfc_buffer_error (1);
660 if ((gfc_option
.warn_line_truncation
|| gfc_current_form
== FORM_FREE
)
661 && gfc_current_locus
.lb
662 && gfc_current_locus
.lb
->truncated
)
663 gfc_warning_now ("Line truncated at %C");
668 gfc_skip_comments ();
676 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
682 gfc_buffer_error (0);
685 check_statement_label (st
);
691 /****************************** Parser ***********************************/
693 /* The parser subroutines are of type 'try' that fail if the file ends
696 /* Macros that expand to case-labels for various classes of
697 statements. Start with executable statements that directly do
700 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
701 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
702 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
703 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
704 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
705 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
706 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
707 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
710 /* Statements that mark other executable statements. */
712 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
713 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
714 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
715 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
716 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
717 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
719 /* Declaration statements */
721 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
722 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
723 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
726 /* Block end statements. Errors associated with interchanging these
727 are detected in gfc_match_end(). */
729 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
730 case ST_END_PROGRAM: case ST_END_SUBROUTINE
733 /* Push a new state onto the stack. */
736 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
738 p
->state
= new_state
;
739 p
->previous
= gfc_state_stack
;
741 p
->head
= p
->tail
= NULL
;
742 p
->do_variable
= NULL
;
747 /* Pop the current state. */
751 gfc_state_stack
= gfc_state_stack
->previous
;
755 /* Try to find the given state in the state stack. */
758 gfc_find_state (gfc_compile_state state
)
762 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
763 if (p
->state
== state
)
766 return (p
== NULL
) ? FAILURE
: SUCCESS
;
770 /* Starts a new level in the statement list. */
773 new_level (gfc_code
*q
)
777 p
= q
->block
= gfc_get_code ();
779 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
785 /* Add the current new_st code structure and adds it to the current
786 program unit. As a side-effect, it zeroes the new_st. */
796 p
->loc
= gfc_current_locus
;
798 if (gfc_state_stack
->head
== NULL
)
799 gfc_state_stack
->head
= p
;
801 gfc_state_stack
->tail
->next
= p
;
803 while (p
->next
!= NULL
)
806 gfc_state_stack
->tail
= p
;
814 /* Frees everything associated with the current statement. */
817 undo_new_statement (void)
819 gfc_free_statements (new_st
.block
);
820 gfc_free_statements (new_st
.next
);
821 gfc_free_statement (&new_st
);
826 /* If the current statement has a statement label, make sure that it
827 is allowed to, or should have one. */
830 check_statement_label (gfc_statement st
)
834 if (gfc_statement_label
== NULL
)
837 gfc_error ("FORMAT statement at %L does not have a statement label",
845 case ST_END_FUNCTION
:
846 case ST_END_SUBROUTINE
:
852 type
= ST_LABEL_TARGET
;
856 type
= ST_LABEL_FORMAT
;
859 /* Statement labels are not restricted from appearing on a
860 particular line. However, there are plenty of situations
861 where the resulting label can't be referenced. */
864 type
= ST_LABEL_BAD_TARGET
;
868 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
870 new_st
.here
= gfc_statement_label
;
874 /* Figures out what the enclosing program unit is. This will be a
875 function, subroutine, program, block data or module. */
878 gfc_enclosing_unit (gfc_compile_state
* result
)
882 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
883 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
884 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
885 || p
->state
== COMP_PROGRAM
)
894 *result
= COMP_PROGRAM
;
899 /* Translate a statement enum to a string. */
902 gfc_ascii_statement (gfc_statement st
)
908 case ST_ARITHMETIC_IF
:
909 p
= _("arithmetic IF");
915 p
= _("attribute declaration");
945 p
= _("data declaration");
953 case ST_DERIVED_DECL
:
954 p
= _("derived type declaration");
968 case ST_END_BLOCK_DATA
:
969 p
= "END BLOCK DATA";
980 case ST_END_FUNCTION
:
986 case ST_END_INTERFACE
:
998 case ST_END_SUBROUTINE
:
999 p
= "END SUBROUTINE";
1010 case ST_EQUIVALENCE
:
1019 case ST_FORALL_BLOCK
: /* Fall through */
1038 case ST_IMPLICIT_NONE
:
1039 p
= "IMPLICIT NONE";
1041 case ST_IMPLIED_ENDDO
:
1042 p
= _("implied END DO");
1068 case ST_MODULE_PROC
:
1069 p
= "MODULE PROCEDURE";
1107 case ST_WHERE_BLOCK
: /* Fall through */
1115 p
= _("assignment");
1117 case ST_POINTER_ASSIGNMENT
:
1118 p
= _("pointer assignment");
1120 case ST_SELECT_CASE
:
1129 case ST_STATEMENT_FUNCTION
:
1130 p
= "STATEMENT FUNCTION";
1132 case ST_LABEL_ASSIGNMENT
:
1133 p
= "LABEL ASSIGNMENT";
1136 p
= "ENUM DEFINITION";
1139 p
= "ENUMERATOR DEFINITION";
1147 case ST_OMP_BARRIER
:
1148 p
= "!$OMP BARRIER";
1150 case ST_OMP_CRITICAL
:
1151 p
= "!$OMP CRITICAL";
1156 case ST_OMP_END_CRITICAL
:
1157 p
= "!$OMP END CRITICAL";
1162 case ST_OMP_END_MASTER
:
1163 p
= "!$OMP END MASTER";
1165 case ST_OMP_END_ORDERED
:
1166 p
= "!$OMP END ORDERED";
1168 case ST_OMP_END_PARALLEL
:
1169 p
= "!$OMP END PARALLEL";
1171 case ST_OMP_END_PARALLEL_DO
:
1172 p
= "!$OMP END PARALLEL DO";
1174 case ST_OMP_END_PARALLEL_SECTIONS
:
1175 p
= "!$OMP END PARALLEL SECTIONS";
1177 case ST_OMP_END_PARALLEL_WORKSHARE
:
1178 p
= "!$OMP END PARALLEL WORKSHARE";
1180 case ST_OMP_END_SECTIONS
:
1181 p
= "!$OMP END SECTIONS";
1183 case ST_OMP_END_SINGLE
:
1184 p
= "!$OMP END SINGLE";
1186 case ST_OMP_END_WORKSHARE
:
1187 p
= "!$OMP END WORKSHARE";
1195 case ST_OMP_ORDERED
:
1196 p
= "!$OMP ORDERED";
1198 case ST_OMP_PARALLEL
:
1199 p
= "!$OMP PARALLEL";
1201 case ST_OMP_PARALLEL_DO
:
1202 p
= "!$OMP PARALLEL DO";
1204 case ST_OMP_PARALLEL_SECTIONS
:
1205 p
= "!$OMP PARALLEL SECTIONS";
1207 case ST_OMP_PARALLEL_WORKSHARE
:
1208 p
= "!$OMP PARALLEL WORKSHARE";
1210 case ST_OMP_SECTIONS
:
1211 p
= "!$OMP SECTIONS";
1213 case ST_OMP_SECTION
:
1214 p
= "!$OMP SECTION";
1219 case ST_OMP_THREADPRIVATE
:
1220 p
= "!$OMP THREADPRIVATE";
1222 case ST_OMP_WORKSHARE
:
1223 p
= "!$OMP WORKSHARE";
1226 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1233 /* Create a symbol for the main program and assign it to ns->proc_name. */
1236 main_program_symbol (gfc_namespace
*ns
)
1238 gfc_symbol
*main_program
;
1239 symbol_attribute attr
;
1241 gfc_get_symbol ("MAIN__", ns
, &main_program
);
1242 gfc_clear_attr (&attr
);
1243 attr
.flavor
= FL_PROCEDURE
;
1244 attr
.proc
= PROC_UNKNOWN
;
1245 attr
.subroutine
= 1;
1246 attr
.access
= ACCESS_PUBLIC
;
1247 attr
.is_main_program
= 1;
1248 main_program
->attr
= attr
;
1249 main_program
->declared_at
= gfc_current_locus
;
1250 ns
->proc_name
= main_program
;
1251 gfc_commit_symbols ();
1255 /* Do whatever is necessary to accept the last statement. */
1258 accept_statement (gfc_statement st
)
1266 case ST_IMPLICIT_NONE
:
1267 gfc_set_implicit_none ();
1276 gfc_current_ns
->proc_name
= gfc_new_block
;
1279 /* If the statement is the end of a block, lay down a special code
1280 that allows a branch to the end of the block from within the
1285 if (gfc_statement_label
!= NULL
)
1287 new_st
.op
= EXEC_NOP
;
1293 /* The end-of-program unit statements do not get the special
1294 marker and require a statement of some sort if they are a
1297 case ST_END_PROGRAM
:
1298 case ST_END_FUNCTION
:
1299 case ST_END_SUBROUTINE
:
1300 if (gfc_statement_label
!= NULL
)
1302 new_st
.op
= EXEC_RETURN
;
1318 gfc_commit_symbols ();
1319 gfc_warning_check ();
1320 gfc_clear_new_st ();
1324 /* Undo anything tentative that has been built for the current
1328 reject_statement (void)
1330 gfc_new_block
= NULL
;
1331 gfc_undo_symbols ();
1332 gfc_clear_warning ();
1333 undo_new_statement ();
1337 /* Generic complaint about an out of order statement. We also do
1338 whatever is necessary to clean up. */
1341 unexpected_statement (gfc_statement st
)
1343 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1345 reject_statement ();
1349 /* Given the next statement seen by the matcher, make sure that it is
1350 in proper order with the last. This subroutine is initialized by
1351 calling it with an argument of ST_NONE. If there is a problem, we
1352 issue an error and return FAILURE. Otherwise we return SUCCESS.
1354 Individual parsers need to verify that the statements seen are
1355 valid before calling here, ie ENTRY statements are not allowed in
1356 INTERFACE blocks. The following diagram is taken from the standard:
1358 +---------------------------------------+
1359 | program subroutine function module |
1360 +---------------------------------------+
1362 +---------------------------------------+
1364 +---------------------------------------+
1366 | +-----------+------------------+
1367 | | parameter | implicit |
1368 | +-----------+------------------+
1369 | format | | derived type |
1370 | entry | parameter | interface |
1371 | | data | specification |
1372 | | | statement func |
1373 | +-----------+------------------+
1374 | | data | executable |
1375 +--------+-----------+------------------+
1377 +---------------------------------------+
1378 | internal module/subprogram |
1379 +---------------------------------------+
1381 +---------------------------------------+
1388 { ORDER_START
, ORDER_USE
, ORDER_IMPORT
, ORDER_IMPLICIT_NONE
,
1389 ORDER_IMPLICIT
, ORDER_SPEC
, ORDER_EXEC
1392 gfc_statement last_statement
;
1398 verify_st_order (st_state
*p
, gfc_statement st
)
1404 p
->state
= ORDER_START
;
1408 if (p
->state
> ORDER_USE
)
1410 p
->state
= ORDER_USE
;
1414 if (p
->state
> ORDER_IMPORT
)
1416 p
->state
= ORDER_IMPORT
;
1419 case ST_IMPLICIT_NONE
:
1420 if (p
->state
> ORDER_IMPLICIT_NONE
)
1423 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1424 statement disqualifies a USE but not an IMPLICIT NONE.
1425 Duplicate IMPLICIT NONEs are caught when the implicit types
1428 p
->state
= ORDER_IMPLICIT_NONE
;
1432 if (p
->state
> ORDER_IMPLICIT
)
1434 p
->state
= ORDER_IMPLICIT
;
1439 if (p
->state
< ORDER_IMPLICIT_NONE
)
1440 p
->state
= ORDER_IMPLICIT_NONE
;
1444 if (p
->state
>= ORDER_EXEC
)
1446 if (p
->state
< ORDER_IMPLICIT
)
1447 p
->state
= ORDER_IMPLICIT
;
1451 if (p
->state
< ORDER_SPEC
)
1452 p
->state
= ORDER_SPEC
;
1457 case ST_DERIVED_DECL
:
1459 if (p
->state
>= ORDER_EXEC
)
1461 if (p
->state
< ORDER_SPEC
)
1462 p
->state
= ORDER_SPEC
;
1467 if (p
->state
< ORDER_EXEC
)
1468 p
->state
= ORDER_EXEC
;
1472 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1473 gfc_ascii_statement (st
));
1476 /* All is well, record the statement in case we need it next time. */
1477 p
->where
= gfc_current_locus
;
1478 p
->last_statement
= st
;
1482 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1483 gfc_ascii_statement (st
),
1484 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1490 /* Handle an unexpected end of file. This is a show-stopper... */
1492 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1495 unexpected_eof (void)
1499 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1501 /* Memory cleanup. Move to "second to last". */
1502 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1505 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1508 longjmp (eof_buf
, 1);
1512 /* Parse a derived type. */
1515 parse_derived (void)
1517 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1520 gfc_symbol
*derived_sym
= NULL
;
1526 accept_statement (ST_DERIVED_DECL
);
1527 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1529 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1536 while (compiling_type
)
1538 st
= next_statement ();
1546 accept_statement (st
);
1554 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
1555 "definition at %C without components")
1559 accept_statement (ST_END_TYPE
);
1563 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1565 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1573 gfc_error ("PRIVATE statement at %C must precede "
1574 "structure components");
1581 gfc_error ("Duplicate PRIVATE statement at %C");
1585 s
.sym
->component_access
= ACCESS_PRIVATE
;
1586 accept_statement (ST_PRIVATE
);
1593 gfc_error ("SEQUENCE statement at %C must precede "
1594 "structure components");
1599 if (gfc_current_block ()->attr
.sequence
)
1600 gfc_warning ("SEQUENCE attribute at %C already specified in "
1605 gfc_error ("Duplicate SEQUENCE statement at %C");
1610 gfc_add_sequence (&gfc_current_block ()->attr
,
1611 gfc_current_block ()->name
, NULL
);
1615 unexpected_statement (st
);
1620 /* need to verify that all fields of the derived type are
1621 * interoperable with C if the type is declared to be bind(c)
1623 derived_sym
= gfc_current_block();
1625 sym
= gfc_current_block ();
1626 for (c
= sym
->components
; c
; c
= c
->next
)
1628 /* Look for allocatable components. */
1630 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.alloc_comp
))
1632 sym
->attr
.alloc_comp
= 1;
1636 /* Look for pointer components. */
1638 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.pointer_comp
))
1640 sym
->attr
.pointer_comp
= 1;
1644 /* Look for private components. */
1645 if (sym
->component_access
== ACCESS_PRIVATE
1646 || c
->access
== ACCESS_PRIVATE
1647 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.private_comp
))
1649 sym
->attr
.private_comp
= 1;
1654 if (!seen_component
)
1655 sym
->attr
.zero_comp
= 1;
1661 /* Parse an ENUM. */
1670 int seen_enumerator
= 0;
1674 push_state (&s
, COMP_ENUM
, gfc_new_block
);
1678 while (compiling_enum
)
1680 st
= next_statement ();
1688 seen_enumerator
= 1;
1689 accept_statement (st
);
1694 if (!seen_enumerator
)
1696 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1699 accept_statement (st
);
1703 gfc_free_enum_history ();
1704 unexpected_statement (st
);
1712 /* Parse an interface. We must be able to deal with the possibility
1713 of recursive interfaces. The parse_spec() subroutine is mutually
1714 recursive with parse_interface(). */
1716 static gfc_statement
parse_spec (gfc_statement
);
1719 parse_interface (void)
1721 gfc_compile_state new_state
, current_state
;
1722 gfc_symbol
*prog_unit
, *sym
;
1723 gfc_interface_info save
;
1724 gfc_state_data s1
, s2
;
1728 accept_statement (ST_INTERFACE
);
1730 current_interface
.ns
= gfc_current_ns
;
1731 save
= current_interface
;
1733 sym
= (current_interface
.type
== INTERFACE_GENERIC
1734 || current_interface
.type
== INTERFACE_USER_OP
)
1735 ? gfc_new_block
: NULL
;
1737 push_state (&s1
, COMP_INTERFACE
, sym
);
1738 current_state
= COMP_NONE
;
1741 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1743 st
= next_statement ();
1750 new_state
= COMP_SUBROUTINE
;
1751 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1752 gfc_new_block
->formal
, NULL
);
1756 new_state
= COMP_FUNCTION
;
1757 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1758 gfc_new_block
->formal
, NULL
);
1762 case ST_MODULE_PROC
: /* The module procedure matcher makes
1763 sure the context is correct. */
1764 accept_statement (st
);
1765 gfc_free_namespace (gfc_current_ns
);
1768 case ST_END_INTERFACE
:
1769 gfc_free_namespace (gfc_current_ns
);
1770 gfc_current_ns
= current_interface
.ns
;
1774 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1775 gfc_ascii_statement (st
));
1776 reject_statement ();
1777 gfc_free_namespace (gfc_current_ns
);
1782 /* Make sure that a generic interface has only subroutines or
1783 functions and that the generic name has the right attribute. */
1784 if (current_interface
.type
== INTERFACE_GENERIC
)
1786 if (current_state
== COMP_NONE
)
1788 if (new_state
== COMP_FUNCTION
)
1789 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1790 else if (new_state
== COMP_SUBROUTINE
)
1791 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1793 current_state
= new_state
;
1797 if (new_state
!= current_state
)
1799 if (new_state
== COMP_SUBROUTINE
)
1800 gfc_error ("SUBROUTINE at %C does not belong in a "
1801 "generic function interface");
1803 if (new_state
== COMP_FUNCTION
)
1804 gfc_error ("FUNCTION at %C does not belong in a "
1805 "generic subroutine interface");
1810 if (current_interface
.type
== INTERFACE_ABSTRACT
)
1812 gfc_new_block
->attr
.abstract
= 1;
1813 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
1814 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1815 "cannot be the same as an intrinsic type",
1816 gfc_new_block
->name
);
1819 push_state (&s2
, new_state
, gfc_new_block
);
1820 accept_statement (st
);
1821 prog_unit
= gfc_new_block
;
1822 prog_unit
->formal_ns
= gfc_current_ns
;
1823 proc_locus
= gfc_current_locus
;
1826 /* Read data declaration statements. */
1827 st
= parse_spec (ST_NONE
);
1829 /* Since the interface block does not permit an IMPLICIT statement,
1830 the default type for the function or the result must be taken
1831 from the formal namespace. */
1832 if (new_state
== COMP_FUNCTION
)
1834 if (prog_unit
->result
== prog_unit
1835 && prog_unit
->ts
.type
== BT_UNKNOWN
)
1836 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
1837 else if (prog_unit
->result
!= prog_unit
1838 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
1839 gfc_set_default_type (prog_unit
->result
, 1,
1840 prog_unit
->formal_ns
);
1843 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1845 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1846 gfc_ascii_statement (st
));
1847 reject_statement ();
1851 current_interface
= save
;
1852 gfc_add_interface (prog_unit
);
1855 if (current_interface
.ns
1856 && current_interface
.ns
->proc_name
1857 && strcmp (current_interface
.ns
->proc_name
->name
,
1858 prog_unit
->name
) == 0)
1859 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1860 "enclosing procedure", prog_unit
->name
, &proc_locus
);
1869 /* Parse a set of specification statements. Returns the statement
1870 that doesn't fit. */
1872 static gfc_statement
1873 parse_spec (gfc_statement st
)
1877 verify_st_order (&ss
, ST_NONE
);
1879 st
= next_statement ();
1889 case ST_DATA
: /* Not allowed in interfaces */
1890 if (gfc_current_state () == COMP_INTERFACE
)
1897 case ST_IMPLICIT_NONE
:
1902 case ST_DERIVED_DECL
:
1904 if (verify_st_order (&ss
, st
) == FAILURE
)
1906 reject_statement ();
1907 st
= next_statement ();
1917 case ST_DERIVED_DECL
:
1923 if (gfc_current_state () != COMP_MODULE
)
1925 gfc_error ("%s statement must appear in a MODULE",
1926 gfc_ascii_statement (st
));
1930 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1932 gfc_error ("%s statement at %C follows another accessibility "
1933 "specification", gfc_ascii_statement (st
));
1937 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1938 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1942 case ST_STATEMENT_FUNCTION
:
1943 if (gfc_current_state () == COMP_MODULE
)
1945 unexpected_statement (st
);
1953 accept_statement (st
);
1954 st
= next_statement ();
1958 accept_statement (st
);
1960 st
= next_statement ();
1971 /* Parse a WHERE block, (not a simple WHERE statement). */
1974 parse_where_block (void)
1976 int seen_empty_else
;
1981 accept_statement (ST_WHERE_BLOCK
);
1982 top
= gfc_state_stack
->tail
;
1984 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1986 d
= add_statement ();
1987 d
->expr
= top
->expr
;
1993 seen_empty_else
= 0;
1997 st
= next_statement ();
2003 case ST_WHERE_BLOCK
:
2004 parse_where_block ();
2009 accept_statement (st
);
2013 if (seen_empty_else
)
2015 gfc_error ("ELSEWHERE statement at %C follows previous "
2016 "unmasked ELSEWHERE");
2020 if (new_st
.expr
== NULL
)
2021 seen_empty_else
= 1;
2023 d
= new_level (gfc_state_stack
->head
);
2025 d
->expr
= new_st
.expr
;
2027 accept_statement (st
);
2032 accept_statement (st
);
2036 gfc_error ("Unexpected %s statement in WHERE block at %C",
2037 gfc_ascii_statement (st
));
2038 reject_statement ();
2042 while (st
!= ST_END_WHERE
);
2048 /* Parse a FORALL block (not a simple FORALL statement). */
2051 parse_forall_block (void)
2057 accept_statement (ST_FORALL_BLOCK
);
2058 top
= gfc_state_stack
->tail
;
2060 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2062 d
= add_statement ();
2063 d
->op
= EXEC_FORALL
;
2068 st
= next_statement ();
2073 case ST_POINTER_ASSIGNMENT
:
2076 accept_statement (st
);
2079 case ST_WHERE_BLOCK
:
2080 parse_where_block ();
2083 case ST_FORALL_BLOCK
:
2084 parse_forall_block ();
2088 accept_statement (st
);
2095 gfc_error ("Unexpected %s statement in FORALL block at %C",
2096 gfc_ascii_statement (st
));
2098 reject_statement ();
2102 while (st
!= ST_END_FORALL
);
2108 static gfc_statement
parse_executable (gfc_statement
);
2110 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2113 parse_if_block (void)
2122 accept_statement (ST_IF_BLOCK
);
2124 top
= gfc_state_stack
->tail
;
2125 push_state (&s
, COMP_IF
, gfc_new_block
);
2127 new_st
.op
= EXEC_IF
;
2128 d
= add_statement ();
2130 d
->expr
= top
->expr
;
2136 st
= parse_executable (ST_NONE
);
2146 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2147 "statement at %L", &else_locus
);
2149 reject_statement ();
2153 d
= new_level (gfc_state_stack
->head
);
2155 d
->expr
= new_st
.expr
;
2157 accept_statement (st
);
2164 gfc_error ("Duplicate ELSE statements at %L and %C",
2166 reject_statement ();
2171 else_locus
= gfc_current_locus
;
2173 d
= new_level (gfc_state_stack
->head
);
2176 accept_statement (st
);
2184 unexpected_statement (st
);
2188 while (st
!= ST_ENDIF
);
2191 accept_statement (st
);
2195 /* Parse a SELECT block. */
2198 parse_select_block (void)
2204 accept_statement (ST_SELECT_CASE
);
2206 cp
= gfc_state_stack
->tail
;
2207 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2209 /* Make sure that the next statement is a CASE or END SELECT. */
2212 st
= next_statement ();
2215 if (st
== ST_END_SELECT
)
2217 /* Empty SELECT CASE is OK. */
2218 accept_statement (st
);
2225 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2228 reject_statement ();
2231 /* At this point, we're got a nonempty select block. */
2232 cp
= new_level (cp
);
2235 accept_statement (st
);
2239 st
= parse_executable (ST_NONE
);
2246 cp
= new_level (gfc_state_stack
->head
);
2248 gfc_clear_new_st ();
2250 accept_statement (st
);
2256 /* Can't have an executable statement because of
2257 parse_executable(). */
2259 unexpected_statement (st
);
2263 while (st
!= ST_END_SELECT
);
2266 accept_statement (st
);
2270 /* Given a symbol, make sure it is not an iteration variable for a DO
2271 statement. This subroutine is called when the symbol is seen in a
2272 context that causes it to become redefined. If the symbol is an
2273 iterator, we generate an error message and return nonzero. */
2276 gfc_check_do_variable (gfc_symtree
*st
)
2280 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2281 if (s
->do_variable
== st
)
2283 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2284 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2292 /* Checks to see if the current statement label closes an enddo.
2293 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2294 an error) if it incorrectly closes an ENDDO. */
2297 check_do_closure (void)
2301 if (gfc_statement_label
== NULL
)
2304 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2305 if (p
->state
== COMP_DO
)
2309 return 0; /* No loops to close */
2311 if (p
->ext
.end_do_label
== gfc_statement_label
)
2314 if (p
== gfc_state_stack
)
2317 gfc_error ("End of nonblock DO statement at %C is within another block");
2321 /* At this point, the label doesn't terminate the innermost loop.
2322 Make sure it doesn't terminate another one. */
2323 for (; p
; p
= p
->previous
)
2324 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
2326 gfc_error ("End of nonblock DO statement at %C is interwoven "
2327 "with another DO loop");
2335 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2336 handled inside of parse_executable(), because they aren't really
2340 parse_do_block (void)
2347 s
.ext
.end_do_label
= new_st
.label
;
2349 if (new_st
.ext
.iterator
!= NULL
)
2350 stree
= new_st
.ext
.iterator
->var
->symtree
;
2354 accept_statement (ST_DO
);
2356 top
= gfc_state_stack
->tail
;
2357 push_state (&s
, COMP_DO
, gfc_new_block
);
2359 s
.do_variable
= stree
;
2361 top
->block
= new_level (top
);
2362 top
->block
->op
= EXEC_DO
;
2365 st
= parse_executable (ST_NONE
);
2373 if (s
.ext
.end_do_label
!= NULL
2374 && s
.ext
.end_do_label
!= gfc_statement_label
)
2375 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2378 if (gfc_statement_label
!= NULL
)
2380 new_st
.op
= EXEC_NOP
;
2385 case ST_IMPLIED_ENDDO
:
2386 /* If the do-stmt of this DO construct has a do-construct-name,
2387 the corresponding end-do must be an end-do-stmt (with a matching
2388 name, but in that case we must have seen ST_ENDDO first).
2389 We only complain about this in pedantic mode. */
2390 if (gfc_current_block () != NULL
)
2391 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2392 &gfc_current_block()->declared_at
);
2397 unexpected_statement (st
);
2402 accept_statement (st
);
2406 /* Parse the statements of OpenMP do/parallel do. */
2408 static gfc_statement
2409 parse_omp_do (gfc_statement omp_st
)
2415 accept_statement (omp_st
);
2417 cp
= gfc_state_stack
->tail
;
2418 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2419 np
= new_level (cp
);
2425 st
= next_statement ();
2428 else if (st
== ST_DO
)
2431 unexpected_statement (st
);
2435 if (gfc_statement_label
!= NULL
2436 && gfc_state_stack
->previous
!= NULL
2437 && gfc_state_stack
->previous
->state
== COMP_DO
2438 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
2446 there should be no !$OMP END DO. */
2448 return ST_IMPLIED_ENDDO
;
2451 check_do_closure ();
2454 st
= next_statement ();
2455 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
2457 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
2458 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2460 gcc_assert (new_st
.op
== EXEC_NOP
);
2461 gfc_clear_new_st ();
2462 gfc_commit_symbols ();
2463 gfc_warning_check ();
2464 st
= next_statement ();
2470 /* Parse the statements of OpenMP atomic directive. */
2473 parse_omp_atomic (void)
2479 accept_statement (ST_OMP_ATOMIC
);
2481 cp
= gfc_state_stack
->tail
;
2482 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2483 np
= new_level (cp
);
2489 st
= next_statement ();
2492 else if (st
== ST_ASSIGNMENT
)
2495 unexpected_statement (st
);
2498 accept_statement (st
);
2504 /* Parse the statements of an OpenMP structured block. */
2507 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
2509 gfc_statement st
, omp_end_st
;
2513 accept_statement (omp_st
);
2515 cp
= gfc_state_stack
->tail
;
2516 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2517 np
= new_level (cp
);
2523 case ST_OMP_PARALLEL
:
2524 omp_end_st
= ST_OMP_END_PARALLEL
;
2526 case ST_OMP_PARALLEL_SECTIONS
:
2527 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
2529 case ST_OMP_SECTIONS
:
2530 omp_end_st
= ST_OMP_END_SECTIONS
;
2532 case ST_OMP_ORDERED
:
2533 omp_end_st
= ST_OMP_END_ORDERED
;
2535 case ST_OMP_CRITICAL
:
2536 omp_end_st
= ST_OMP_END_CRITICAL
;
2539 omp_end_st
= ST_OMP_END_MASTER
;
2542 omp_end_st
= ST_OMP_END_SINGLE
;
2544 case ST_OMP_WORKSHARE
:
2545 omp_end_st
= ST_OMP_END_WORKSHARE
;
2547 case ST_OMP_PARALLEL_WORKSHARE
:
2548 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
2556 if (workshare_stmts_only
)
2558 /* Inside of !$omp workshare, only
2561 where statements and constructs
2562 forall statements and constructs
2566 are allowed. For !$omp critical these
2567 restrictions apply recursively. */
2570 st
= next_statement ();
2581 accept_statement (st
);
2584 case ST_WHERE_BLOCK
:
2585 parse_where_block ();
2588 case ST_FORALL_BLOCK
:
2589 parse_forall_block ();
2592 case ST_OMP_PARALLEL
:
2593 case ST_OMP_PARALLEL_SECTIONS
:
2594 parse_omp_structured_block (st
, false);
2597 case ST_OMP_PARALLEL_WORKSHARE
:
2598 case ST_OMP_CRITICAL
:
2599 parse_omp_structured_block (st
, true);
2602 case ST_OMP_PARALLEL_DO
:
2603 st
= parse_omp_do (st
);
2607 parse_omp_atomic ();
2618 st
= next_statement ();
2622 st
= parse_executable (ST_NONE
);
2625 else if (st
== ST_OMP_SECTION
2626 && (omp_st
== ST_OMP_SECTIONS
2627 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
2629 np
= new_level (np
);
2633 else if (st
!= omp_end_st
)
2634 unexpected_statement (st
);
2636 while (st
!= omp_end_st
);
2640 case EXEC_OMP_END_NOWAIT
:
2641 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2643 case EXEC_OMP_CRITICAL
:
2644 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
2645 || (new_st
.ext
.omp_name
!= NULL
2646 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
2647 gfc_error ("Name after !$omp critical and !$omp end critical does "
2649 gfc_free (CONST_CAST (char *, new_st
.ext
.omp_name
));
2651 case EXEC_OMP_END_SINGLE
:
2652 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
2653 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
2654 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
2655 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
2663 gfc_clear_new_st ();
2664 gfc_commit_symbols ();
2665 gfc_warning_check ();
2670 /* Accept a series of executable statements. We return the first
2671 statement that doesn't fit to the caller. Any block statements are
2672 passed on to the correct handler, which usually passes the buck
2675 static gfc_statement
2676 parse_executable (gfc_statement st
)
2681 st
= next_statement ();
2685 close_flag
= check_do_closure ();
2690 case ST_END_PROGRAM
:
2693 case ST_END_FUNCTION
:
2697 case ST_END_SUBROUTINE
:
2702 case ST_SELECT_CASE
:
2703 gfc_error ("%s statement at %C cannot terminate a non-block "
2704 "DO loop", gfc_ascii_statement (st
));
2720 accept_statement (st
);
2721 if (close_flag
== 1)
2722 return ST_IMPLIED_ENDDO
;
2729 case ST_SELECT_CASE
:
2730 parse_select_block ();
2735 if (check_do_closure () == 1)
2736 return ST_IMPLIED_ENDDO
;
2739 case ST_WHERE_BLOCK
:
2740 parse_where_block ();
2743 case ST_FORALL_BLOCK
:
2744 parse_forall_block ();
2747 case ST_OMP_PARALLEL
:
2748 case ST_OMP_PARALLEL_SECTIONS
:
2749 case ST_OMP_SECTIONS
:
2750 case ST_OMP_ORDERED
:
2751 case ST_OMP_CRITICAL
:
2754 parse_omp_structured_block (st
, false);
2757 case ST_OMP_WORKSHARE
:
2758 case ST_OMP_PARALLEL_WORKSHARE
:
2759 parse_omp_structured_block (st
, true);
2763 case ST_OMP_PARALLEL_DO
:
2764 st
= parse_omp_do (st
);
2765 if (st
== ST_IMPLIED_ENDDO
)
2770 parse_omp_atomic ();
2777 st
= next_statement ();
2782 /* Parse a series of contained program units. */
2784 static void parse_progunit (gfc_statement
);
2787 /* Fix the symbols for sibling functions. These are incorrectly added to
2788 the child namespace as the parser didn't know about this procedure. */
2791 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
2795 gfc_symbol
*old_sym
;
2797 sym
->attr
.referenced
= 1;
2798 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2800 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2802 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
2805 old_sym
= st
->n
.sym
;
2806 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2807 || old_sym
->ts
.type
== BT_UNKNOWN
)
2808 && old_sym
->ns
== ns
2809 && !old_sym
->attr
.contained
2810 && old_sym
->attr
.flavor
!= FL_NAMELIST
)
2812 /* Replace it with the symbol from the parent namespace. */
2816 /* Free the old (local) symbol. */
2818 if (old_sym
->refs
== 0)
2819 gfc_free_symbol (old_sym
);
2822 /* Do the same for any contained procedures. */
2823 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2828 parse_contained (int module
)
2830 gfc_namespace
*ns
, *parent_ns
, *tmp
;
2831 gfc_state_data s1
, s2
;
2835 int contains_statements
= 0;
2838 push_state (&s1
, COMP_CONTAINS
, NULL
);
2839 parent_ns
= gfc_current_ns
;
2843 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
2845 gfc_current_ns
->sibling
= parent_ns
->contained
;
2846 parent_ns
->contained
= gfc_current_ns
;
2849 /* Process the next available statement. We come here if we got an error
2850 and rejected the last statement. */
2851 st
= next_statement ();
2860 contains_statements
= 1;
2861 accept_statement (st
);
2864 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2867 /* For internal procedures, create/update the symbol in the
2868 parent namespace. */
2872 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2873 gfc_error ("Contained procedure '%s' at %C is already "
2874 "ambiguous", gfc_new_block
->name
);
2877 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
2878 &gfc_new_block
->declared_at
) ==
2881 if (st
== ST_FUNCTION
)
2882 gfc_add_function (&sym
->attr
, sym
->name
,
2883 &gfc_new_block
->declared_at
);
2885 gfc_add_subroutine (&sym
->attr
, sym
->name
,
2886 &gfc_new_block
->declared_at
);
2890 gfc_commit_symbols ();
2893 sym
= gfc_new_block
;
2895 /* Mark this as a contained function, so it isn't replaced
2896 by other module functions. */
2897 sym
->attr
.contained
= 1;
2898 sym
->attr
.referenced
= 1;
2900 parse_progunit (ST_NONE
);
2902 /* Fix up any sibling functions that refer to this one. */
2903 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2904 /* Or refer to any of its alternate entry points. */
2905 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2906 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2908 gfc_current_ns
->code
= s2
.head
;
2909 gfc_current_ns
= parent_ns
;
2914 /* These statements are associated with the end of the host unit. */
2915 case ST_END_FUNCTION
:
2917 case ST_END_PROGRAM
:
2918 case ST_END_SUBROUTINE
:
2919 accept_statement (st
);
2923 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2924 gfc_ascii_statement (st
));
2925 reject_statement ();
2931 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2932 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2934 /* The first namespace in the list is guaranteed to not have
2935 anything (worthwhile) in it. */
2936 tmp
= gfc_current_ns
;
2937 gfc_current_ns
= parent_ns
;
2938 if (seen_error
&& tmp
->refs
> 1)
2939 gfc_free_namespace (tmp
);
2941 ns
= gfc_current_ns
->contained
;
2942 gfc_current_ns
->contained
= ns
->sibling
;
2943 gfc_free_namespace (ns
);
2946 if (!contains_statements
)
2947 /* This is valid in Fortran 2008. */
2948 gfc_notify_std (GFC_STD_GNU
, "Extension: CONTAINS statement without "
2949 "FUNCTION or SUBROUTINE statement at %C");
2953 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2956 parse_progunit (gfc_statement st
)
2961 st
= parse_spec (st
);
2971 accept_statement (st
);
2978 if (gfc_current_state () == COMP_FUNCTION
)
2979 gfc_check_function_type (gfc_current_ns
);
2984 st
= parse_executable (st
);
2995 accept_statement (st
);
3002 unexpected_statement (st
);
3003 reject_statement ();
3004 st
= next_statement ();
3010 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3011 if (p
->state
== COMP_CONTAINS
)
3014 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
3019 gfc_error ("CONTAINS statement at %C is already in a contained "
3021 st
= next_statement ();
3025 parse_contained (0);
3028 gfc_current_ns
->code
= gfc_state_stack
->head
;
3032 /* Come here to complain about a global symbol already in use as
3036 global_used (gfc_gsymbol
*sym
, locus
*where
)
3041 where
= &gfc_current_locus
;
3051 case GSYM_SUBROUTINE
:
3052 name
= "SUBROUTINE";
3057 case GSYM_BLOCK_DATA
:
3058 name
= "BLOCK DATA";
3064 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3068 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3069 sym
->name
, where
, name
, &sym
->where
);
3073 /* Parse a block data program unit. */
3076 parse_block_data (void)
3079 static locus blank_locus
;
3080 static int blank_block
=0;
3083 gfc_current_ns
->proc_name
= gfc_new_block
;
3084 gfc_current_ns
->is_block_data
= 1;
3086 if (gfc_new_block
== NULL
)
3089 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3090 "prior BLOCK DATA at %L", &blank_locus
);
3094 blank_locus
= gfc_current_locus
;
3099 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3101 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3102 global_used(s
, NULL
);
3105 s
->type
= GSYM_BLOCK_DATA
;
3106 s
->where
= gfc_current_locus
;
3111 st
= parse_spec (ST_NONE
);
3113 while (st
!= ST_END_BLOCK_DATA
)
3115 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3116 gfc_ascii_statement (st
));
3117 reject_statement ();
3118 st
= next_statement ();
3123 /* Parse a module subprogram. */
3131 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3132 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3133 global_used(s
, NULL
);
3136 s
->type
= GSYM_MODULE
;
3137 s
->where
= gfc_current_locus
;
3141 st
= parse_spec (ST_NONE
);
3150 parse_contained (1);
3154 accept_statement (st
);
3158 gfc_error ("Unexpected %s statement in MODULE at %C",
3159 gfc_ascii_statement (st
));
3161 reject_statement ();
3162 st
= next_statement ();
3168 /* Add a procedure name to the global symbol table. */
3171 add_global_procedure (int sub
)
3175 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3178 || (s
->type
!= GSYM_UNKNOWN
3179 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3180 global_used(s
, NULL
);
3183 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3184 s
->where
= gfc_current_locus
;
3190 /* Add a program to the global symbol table. */
3193 add_global_program (void)
3197 if (gfc_new_block
== NULL
)
3199 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3201 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
3202 global_used(s
, NULL
);
3205 s
->type
= GSYM_PROGRAM
;
3206 s
->where
= gfc_current_locus
;
3212 /* Top level parser. */
3215 gfc_parse_file (void)
3217 int seen_program
, errors_before
, errors
;
3218 gfc_state_data top
, s
;
3222 top
.state
= COMP_NONE
;
3224 top
.previous
= NULL
;
3225 top
.head
= top
.tail
= NULL
;
3226 top
.do_variable
= NULL
;
3228 gfc_state_stack
= &top
;
3230 gfc_clear_new_st ();
3232 gfc_statement_label
= NULL
;
3234 if (setjmp (eof_buf
))
3235 return FAILURE
; /* Come here on unexpected EOF */
3239 /* Exit early for empty files. */
3245 st
= next_statement ();
3254 goto duplicate_main
;
3256 prog_locus
= gfc_current_locus
;
3258 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3259 main_program_symbol(gfc_current_ns
);
3260 accept_statement (st
);
3261 add_global_program ();
3262 parse_progunit (ST_NONE
);
3266 add_global_procedure (1);
3267 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
3268 accept_statement (st
);
3269 parse_progunit (ST_NONE
);
3273 add_global_procedure (0);
3274 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
3275 accept_statement (st
);
3276 parse_progunit (ST_NONE
);
3280 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
3281 accept_statement (st
);
3282 parse_block_data ();
3286 push_state (&s
, COMP_MODULE
, gfc_new_block
);
3287 accept_statement (st
);
3289 gfc_get_errors (NULL
, &errors_before
);
3293 /* Anything else starts a nameless main program block. */
3296 goto duplicate_main
;
3298 prog_locus
= gfc_current_locus
;
3300 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3301 main_program_symbol (gfc_current_ns
);
3302 parse_progunit (st
);
3306 gfc_current_ns
->code
= s
.head
;
3308 gfc_resolve (gfc_current_ns
);
3310 /* Dump the parse tree if requested. */
3311 if (gfc_option
.verbose
)
3312 gfc_show_namespace (gfc_current_ns
);
3314 gfc_get_errors (NULL
, &errors
);
3315 if (s
.state
== COMP_MODULE
)
3317 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
3319 gfc_generate_module_code (gfc_current_ns
);
3324 gfc_generate_code (gfc_current_ns
);
3335 /* If we see a duplicate main program, shut down. If the second
3336 instance is an implied main program, ie data decls or executable
3337 statements, we're in for lots of errors. */
3338 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
3339 reject_statement ();