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;
1658 /* Parse an ENUM. */
1667 int seen_enumerator = 0;
1671 push_state (&s, COMP_ENUM, gfc_new_block);
1675 while (compiling_enum)
1677 st = next_statement ();
1685 seen_enumerator = 1;
1686 accept_statement (st);
1691 if (!seen_enumerator)
1693 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1696 accept_statement (st);
1700 gfc_free_enum_history ();
1701 unexpected_statement (st);
1709 /* Parse an interface. We must be able to deal with the possibility
1710 of recursive interfaces. The parse_spec() subroutine is mutually
1711 recursive with parse_interface(). */
1713 static gfc_statement parse_spec (gfc_statement);
1716 parse_interface (void)
1718 gfc_compile_state new_state, current_state;
1719 gfc_symbol *prog_unit, *sym;
1720 gfc_interface_info save;
1721 gfc_state_data s1, s2;
1725 accept_statement (ST_INTERFACE);
1727 current_interface.ns = gfc_current_ns;
1728 save = current_interface;
1730 sym = (current_interface.type == INTERFACE_GENERIC
1731 || current_interface.type == INTERFACE_USER_OP)
1732 ? gfc_new_block : NULL;
1734 push_state (&s1, COMP_INTERFACE, sym);
1735 current_state = COMP_NONE;
1738 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1740 st = next_statement ();
1747 new_state = COMP_SUBROUTINE;
1748 gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1749 gfc_new_block->formal, NULL);
1753 new_state = COMP_FUNCTION;
1754 gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1755 gfc_new_block->formal, NULL);
1759 case ST_MODULE_PROC: /* The module procedure matcher makes
1760 sure the context is correct. */
1761 accept_statement (st);
1762 gfc_free_namespace (gfc_current_ns);
1765 case ST_END_INTERFACE:
1766 gfc_free_namespace (gfc_current_ns);
1767 gfc_current_ns = current_interface.ns;
1771 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1772 gfc_ascii_statement (st));
1773 reject_statement ();
1774 gfc_free_namespace (gfc_current_ns);
1779 /* Make sure that a generic interface has only subroutines or
1780 functions and that the generic name has the right attribute. */
1781 if (current_interface.type == INTERFACE_GENERIC)
1783 if (current_state == COMP_NONE)
1785 if (new_state == COMP_FUNCTION)
1786 gfc_add_function (&sym->attr, sym->name, NULL);
1787 else if (new_state == COMP_SUBROUTINE)
1788 gfc_add_subroutine (&sym->attr, sym->name, NULL);
1790 current_state = new_state;
1794 if (new_state != current_state)
1796 if (new_state == COMP_SUBROUTINE)
1797 gfc_error ("SUBROUTINE at %C does not belong in a "
1798 "generic function interface");
1800 if (new_state == COMP_FUNCTION)
1801 gfc_error ("FUNCTION at %C does not belong in a "
1802 "generic subroutine interface");
1807 if (current_interface.type == INTERFACE_ABSTRACT)
1809 gfc_new_block->attr.abstract = 1;
1810 if (gfc_is_intrinsic_typename (gfc_new_block->name))
1811 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1812 "cannot be the same as an intrinsic type",
1813 gfc_new_block->name);
1816 push_state (&s2, new_state, gfc_new_block);
1817 accept_statement (st);
1818 prog_unit = gfc_new_block;
1819 prog_unit->formal_ns = gfc_current_ns;
1820 proc_locus = gfc_current_locus;
1823 /* Read data declaration statements. */
1824 st = parse_spec (ST_NONE);
1826 /* Since the interface block does not permit an IMPLICIT statement,
1827 the default type for the function or the result must be taken
1828 from the formal namespace. */
1829 if (new_state == COMP_FUNCTION)
1831 if (prog_unit->result == prog_unit
1832 && prog_unit->ts.type == BT_UNKNOWN)
1833 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
1834 else if (prog_unit->result != prog_unit
1835 && prog_unit->result->ts.type == BT_UNKNOWN)
1836 gfc_set_default_type (prog_unit->result, 1,
1837 prog_unit->formal_ns);
1840 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1842 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1843 gfc_ascii_statement (st));
1844 reject_statement ();
1848 current_interface = save;
1849 gfc_add_interface (prog_unit);
1852 if (current_interface.ns
1853 && current_interface.ns->proc_name
1854 && strcmp (current_interface.ns->proc_name->name,
1855 prog_unit->name) == 0)
1856 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1857 "enclosing procedure", prog_unit->name, &proc_locus);
1866 /* Parse a set of specification statements. Returns the statement
1867 that doesn't fit. */
1869 static gfc_statement
1870 parse_spec (gfc_statement st)
1874 verify_st_order (&ss, ST_NONE);
1876 st = next_statement ();
1886 case ST_DATA: /* Not allowed in interfaces */
1887 if (gfc_current_state () == COMP_INTERFACE)
1894 case ST_IMPLICIT_NONE:
1899 case ST_DERIVED_DECL:
1901 if (verify_st_order (&ss, st) == FAILURE)
1903 reject_statement ();
1904 st = next_statement ();
1914 case ST_DERIVED_DECL:
1920 if (gfc_current_state () != COMP_MODULE)
1922 gfc_error ("%s statement must appear in a MODULE",
1923 gfc_ascii_statement (st));
1927 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1929 gfc_error ("%s statement at %C follows another accessibility "
1930 "specification", gfc_ascii_statement (st));
1934 gfc_current_ns->default_access = (st == ST_PUBLIC)
1935 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1939 case ST_STATEMENT_FUNCTION:
1940 if (gfc_current_state () == COMP_MODULE)
1942 unexpected_statement (st);
1950 accept_statement (st);
1951 st = next_statement ();
1955 accept_statement (st);
1957 st = next_statement ();
1968 /* Parse a WHERE block, (not a simple WHERE statement). */
1971 parse_where_block (void)
1973 int seen_empty_else;
1978 accept_statement (ST_WHERE_BLOCK);
1979 top = gfc_state_stack->tail;
1981 push_state (&s, COMP_WHERE, gfc_new_block);
1983 d = add_statement ();
1984 d->expr = top->expr;
1990 seen_empty_else = 0;
1994 st = next_statement ();
2000 case ST_WHERE_BLOCK:
2001 parse_where_block ();
2006 accept_statement (st);
2010 if (seen_empty_else)
2012 gfc_error ("ELSEWHERE statement at %C follows previous "
2013 "unmasked ELSEWHERE");
2017 if (new_st.expr == NULL)
2018 seen_empty_else = 1;
2020 d = new_level (gfc_state_stack->head);
2022 d->expr = new_st.expr;
2024 accept_statement (st);
2029 accept_statement (st);
2033 gfc_error ("Unexpected %s statement in WHERE block at %C",
2034 gfc_ascii_statement (st));
2035 reject_statement ();
2039 while (st != ST_END_WHERE);
2045 /* Parse a FORALL block (not a simple FORALL statement). */
2048 parse_forall_block (void)
2054 accept_statement (ST_FORALL_BLOCK);
2055 top = gfc_state_stack->tail;
2057 push_state (&s, COMP_FORALL, gfc_new_block);
2059 d = add_statement ();
2060 d->op = EXEC_FORALL;
2065 st = next_statement ();
2070 case ST_POINTER_ASSIGNMENT:
2073 accept_statement (st);
2076 case ST_WHERE_BLOCK:
2077 parse_where_block ();
2080 case ST_FORALL_BLOCK:
2081 parse_forall_block ();
2085 accept_statement (st);
2092 gfc_error ("Unexpected %s statement in FORALL block at %C",
2093 gfc_ascii_statement (st));
2095 reject_statement ();
2099 while (st != ST_END_FORALL);
2105 static gfc_statement parse_executable (gfc_statement);
2107 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2110 parse_if_block (void)
2119 accept_statement (ST_IF_BLOCK);
2121 top = gfc_state_stack->tail;
2122 push_state (&s, COMP_IF, gfc_new_block);
2124 new_st.op = EXEC_IF;
2125 d = add_statement ();
2127 d->expr = top->expr;
2133 st = parse_executable (ST_NONE);
2143 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2144 "statement at %L", &else_locus);
2146 reject_statement ();
2150 d = new_level (gfc_state_stack->head);
2152 d->expr = new_st.expr;
2154 accept_statement (st);
2161 gfc_error ("Duplicate ELSE statements at %L and %C",
2163 reject_statement ();
2168 else_locus = gfc_current_locus;
2170 d = new_level (gfc_state_stack->head);
2173 accept_statement (st);
2181 unexpected_statement (st);
2185 while (st != ST_ENDIF);
2188 accept_statement (st);
2192 /* Parse a SELECT block. */
2195 parse_select_block (void)
2201 accept_statement (ST_SELECT_CASE);
2203 cp = gfc_state_stack->tail;
2204 push_state (&s, COMP_SELECT, gfc_new_block);
2206 /* Make sure that the next statement is a CASE or END SELECT. */
2209 st = next_statement ();
2212 if (st == ST_END_SELECT)
2214 /* Empty SELECT CASE is OK. */
2215 accept_statement (st);
2222 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2225 reject_statement ();
2228 /* At this point, we're got a nonempty select block. */
2229 cp = new_level (cp);
2232 accept_statement (st);
2236 st = parse_executable (ST_NONE);
2243 cp = new_level (gfc_state_stack->head);
2245 gfc_clear_new_st ();
2247 accept_statement (st);
2253 /* Can't have an executable statement because of
2254 parse_executable(). */
2256 unexpected_statement (st);
2260 while (st != ST_END_SELECT);
2263 accept_statement (st);
2267 /* Given a symbol, make sure it is not an iteration variable for a DO
2268 statement. This subroutine is called when the symbol is seen in a
2269 context that causes it to become redefined. If the symbol is an
2270 iterator, we generate an error message and return nonzero. */
2273 gfc_check_do_variable (gfc_symtree *st)
2277 for (s=gfc_state_stack; s; s = s->previous)
2278 if (s->do_variable == st)
2280 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2281 "loop beginning at %L", st->name, &s->head->loc);
2289 /* Checks to see if the current statement label closes an enddo.
2290 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2291 an error) if it incorrectly closes an ENDDO. */
2294 check_do_closure (void)
2298 if (gfc_statement_label == NULL)
2301 for (p = gfc_state_stack; p; p = p->previous)
2302 if (p->state == COMP_DO)
2306 return 0; /* No loops to close */
2308 if (p->ext.end_do_label == gfc_statement_label)
2311 if (p == gfc_state_stack)
2314 gfc_error ("End of nonblock DO statement at %C is within another block");
2318 /* At this point, the label doesn't terminate the innermost loop.
2319 Make sure it doesn't terminate another one. */
2320 for (; p; p = p->previous)
2321 if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2323 gfc_error ("End of nonblock DO statement at %C is interwoven "
2324 "with another DO loop");
2332 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2333 handled inside of parse_executable(), because they aren't really
2337 parse_do_block (void)
2344 s.ext.end_do_label = new_st.label;
2346 if (new_st.ext.iterator != NULL)
2347 stree = new_st.ext.iterator->var->symtree;
2351 accept_statement (ST_DO);
2353 top = gfc_state_stack->tail;
2354 push_state (&s, COMP_DO, gfc_new_block);
2356 s.do_variable = stree;
2358 top->block = new_level (top);
2359 top->block->op = EXEC_DO;
2362 st = parse_executable (ST_NONE);
2370 if (s.ext.end_do_label != NULL
2371 && s.ext.end_do_label != gfc_statement_label)
2372 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2375 if (gfc_statement_label != NULL)
2377 new_st.op = EXEC_NOP;
2382 case ST_IMPLIED_ENDDO:
2383 /* If the do-stmt of this DO construct has a do-construct-name,
2384 the corresponding end-do must be an end-do-stmt (with a matching
2385 name, but in that case we must have seen ST_ENDDO first).
2386 We only complain about this in pedantic mode. */
2387 if (gfc_current_block () != NULL)
2388 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2389 &gfc_current_block()->declared_at);
2394 unexpected_statement (st);
2399 accept_statement (st);
2403 /* Parse the statements of OpenMP do/parallel do. */
2405 static gfc_statement
2406 parse_omp_do (gfc_statement omp_st)
2412 accept_statement (omp_st);
2414 cp = gfc_state_stack->tail;
2415 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2416 np = new_level (cp);
2422 st = next_statement ();
2425 else if (st == ST_DO)
2428 unexpected_statement (st);
2432 if (gfc_statement_label != NULL
2433 && gfc_state_stack->previous != NULL
2434 && gfc_state_stack->previous->state == COMP_DO
2435 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2443 there should be no !$OMP END DO. */
2445 return ST_IMPLIED_ENDDO;
2448 check_do_closure ();
2451 st = next_statement ();
2452 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2454 if (new_st.op == EXEC_OMP_END_NOWAIT)
2455 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2457 gcc_assert (new_st.op == EXEC_NOP);
2458 gfc_clear_new_st ();
2459 gfc_commit_symbols ();
2460 gfc_warning_check ();
2461 st = next_statement ();
2467 /* Parse the statements of OpenMP atomic directive. */
2470 parse_omp_atomic (void)
2476 accept_statement (ST_OMP_ATOMIC);
2478 cp = gfc_state_stack->tail;
2479 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2480 np = new_level (cp);
2486 st = next_statement ();
2489 else if (st == ST_ASSIGNMENT)
2492 unexpected_statement (st);
2495 accept_statement (st);
2501 /* Parse the statements of an OpenMP structured block. */
2504 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2506 gfc_statement st, omp_end_st;
2510 accept_statement (omp_st);
2512 cp = gfc_state_stack->tail;
2513 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2514 np = new_level (cp);
2520 case ST_OMP_PARALLEL:
2521 omp_end_st = ST_OMP_END_PARALLEL;
2523 case ST_OMP_PARALLEL_SECTIONS:
2524 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2526 case ST_OMP_SECTIONS:
2527 omp_end_st = ST_OMP_END_SECTIONS;
2529 case ST_OMP_ORDERED:
2530 omp_end_st = ST_OMP_END_ORDERED;
2532 case ST_OMP_CRITICAL:
2533 omp_end_st = ST_OMP_END_CRITICAL;
2536 omp_end_st = ST_OMP_END_MASTER;
2539 omp_end_st = ST_OMP_END_SINGLE;
2541 case ST_OMP_WORKSHARE:
2542 omp_end_st = ST_OMP_END_WORKSHARE;
2544 case ST_OMP_PARALLEL_WORKSHARE:
2545 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2553 if (workshare_stmts_only)
2555 /* Inside of !$omp workshare, only
2558 where statements and constructs
2559 forall statements and constructs
2563 are allowed. For !$omp critical these
2564 restrictions apply recursively. */
2567 st = next_statement ();
2578 accept_statement (st);
2581 case ST_WHERE_BLOCK:
2582 parse_where_block ();
2585 case ST_FORALL_BLOCK:
2586 parse_forall_block ();
2589 case ST_OMP_PARALLEL:
2590 case ST_OMP_PARALLEL_SECTIONS:
2591 parse_omp_structured_block (st, false);
2594 case ST_OMP_PARALLEL_WORKSHARE:
2595 case ST_OMP_CRITICAL:
2596 parse_omp_structured_block (st, true);
2599 case ST_OMP_PARALLEL_DO:
2600 st = parse_omp_do (st);
2604 parse_omp_atomic ();
2615 st = next_statement ();
2619 st = parse_executable (ST_NONE);
2622 else if (st == ST_OMP_SECTION
2623 && (omp_st == ST_OMP_SECTIONS
2624 || omp_st == ST_OMP_PARALLEL_SECTIONS))
2626 np = new_level (np);
2630 else if (st != omp_end_st)
2631 unexpected_statement (st);
2633 while (st != omp_end_st);
2637 case EXEC_OMP_END_NOWAIT:
2638 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2640 case EXEC_OMP_CRITICAL:
2641 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2642 || (new_st.ext.omp_name != NULL
2643 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2644 gfc_error ("Name after !$omp critical and !$omp end critical does "
2646 gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2648 case EXEC_OMP_END_SINGLE:
2649 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2650 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2651 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2652 gfc_free_omp_clauses (new_st.ext.omp_clauses);
2660 gfc_clear_new_st ();
2661 gfc_commit_symbols ();
2662 gfc_warning_check ();
2667 /* Accept a series of executable statements. We return the first
2668 statement that doesn't fit to the caller. Any block statements are
2669 passed on to the correct handler, which usually passes the buck
2672 static gfc_statement
2673 parse_executable (gfc_statement st)
2678 st = next_statement ();
2682 close_flag = check_do_closure ();
2687 case ST_END_PROGRAM:
2690 case ST_END_FUNCTION:
2694 case ST_END_SUBROUTINE:
2699 case ST_SELECT_CASE:
2700 gfc_error ("%s statement at %C cannot terminate a non-block "
2701 "DO loop", gfc_ascii_statement (st));
2717 accept_statement (st);
2718 if (close_flag == 1)
2719 return ST_IMPLIED_ENDDO;
2726 case ST_SELECT_CASE:
2727 parse_select_block ();
2732 if (check_do_closure () == 1)
2733 return ST_IMPLIED_ENDDO;
2736 case ST_WHERE_BLOCK:
2737 parse_where_block ();
2740 case ST_FORALL_BLOCK:
2741 parse_forall_block ();
2744 case ST_OMP_PARALLEL:
2745 case ST_OMP_PARALLEL_SECTIONS:
2746 case ST_OMP_SECTIONS:
2747 case ST_OMP_ORDERED:
2748 case ST_OMP_CRITICAL:
2751 parse_omp_structured_block (st, false);
2754 case ST_OMP_WORKSHARE:
2755 case ST_OMP_PARALLEL_WORKSHARE:
2756 parse_omp_structured_block (st, true);
2760 case ST_OMP_PARALLEL_DO:
2761 st = parse_omp_do (st);
2762 if (st == ST_IMPLIED_ENDDO)
2767 parse_omp_atomic ();
2774 st = next_statement ();
2779 /* Parse a series of contained program units. */
2781 static void parse_progunit (gfc_statement);
2784 /* Fix the symbols for sibling functions. These are incorrectly added to
2785 the child namespace as the parser didn't know about this procedure. */
2788 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
2792 gfc_symbol *old_sym;
2794 sym->attr.referenced = 1;
2795 for (ns = siblings; ns; ns = ns->sibling)
2797 gfc_find_sym_tree (sym->name, ns, 0, &st);
2799 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
2802 old_sym = st->n.sym;
2803 if ((old_sym->attr.flavor == FL_PROCEDURE
2804 || old_sym->ts.type == BT_UNKNOWN)
2805 && old_sym->ns == ns
2806 && !old_sym->attr.contained
2807 && old_sym->attr.flavor != FL_NAMELIST)
2809 /* Replace it with the symbol from the parent namespace. */
2813 /* Free the old (local) symbol. */
2815 if (old_sym->refs == 0)
2816 gfc_free_symbol (old_sym);
2819 /* Do the same for any contained procedures. */
2820 gfc_fixup_sibling_symbols (sym, ns->contained);
2825 parse_contained (int module)
2827 gfc_namespace *ns, *parent_ns, *tmp;
2828 gfc_state_data s1, s2;
2832 int contains_statements = 0;
2835 push_state (&s1, COMP_CONTAINS, NULL);
2836 parent_ns = gfc_current_ns;
2840 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2842 gfc_current_ns->sibling = parent_ns->contained;
2843 parent_ns->contained = gfc_current_ns;
2846 /* Process the next available statement. We come here if we got an error
2847 and rejected the last statement. */
2848 st = next_statement ();
2857 contains_statements = 1;
2858 accept_statement (st);
2861 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2864 /* For internal procedures, create/update the symbol in the
2865 parent namespace. */
2869 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2870 gfc_error ("Contained procedure '%s' at %C is already "
2871 "ambiguous", gfc_new_block->name);
2874 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2875 &gfc_new_block->declared_at) ==
2878 if (st == ST_FUNCTION)
2879 gfc_add_function (&sym->attr, sym->name,
2880 &gfc_new_block->declared_at);
2882 gfc_add_subroutine (&sym->attr, sym->name,
2883 &gfc_new_block->declared_at);
2887 gfc_commit_symbols ();
2890 sym = gfc_new_block;
2892 /* Mark this as a contained function, so it isn't replaced
2893 by other module functions. */
2894 sym->attr.contained = 1;
2895 sym->attr.referenced = 1;
2897 parse_progunit (ST_NONE);
2899 /* Fix up any sibling functions that refer to this one. */
2900 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2901 /* Or refer to any of its alternate entry points. */
2902 for (el = gfc_current_ns->entries; el; el = el->next)
2903 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2905 gfc_current_ns->code = s2.head;
2906 gfc_current_ns = parent_ns;
2911 /* These statements are associated with the end of the host unit. */
2912 case ST_END_FUNCTION:
2914 case ST_END_PROGRAM:
2915 case ST_END_SUBROUTINE:
2916 accept_statement (st);
2920 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2921 gfc_ascii_statement (st));
2922 reject_statement ();
2928 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2929 && st != ST_END_MODULE && st != ST_END_PROGRAM);
2931 /* The first namespace in the list is guaranteed to not have
2932 anything (worthwhile) in it. */
2933 tmp = gfc_current_ns;
2934 gfc_current_ns = parent_ns;
2935 if (seen_error && tmp->refs > 1)
2936 gfc_free_namespace (tmp);
2938 ns = gfc_current_ns->contained;
2939 gfc_current_ns->contained = ns->sibling;
2940 gfc_free_namespace (ns);
2943 if (!contains_statements)
2944 /* This is valid in Fortran 2008. */
2945 gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
2946 "FUNCTION or SUBROUTINE statement at %C");
2950 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2953 parse_progunit (gfc_statement st)
2958 st = parse_spec (st);
2968 accept_statement (st);
2975 if (gfc_current_state () == COMP_FUNCTION)
2976 gfc_check_function_type (gfc_current_ns);
2981 st = parse_executable (st);
2992 accept_statement (st);
2999 unexpected_statement (st);
3000 reject_statement ();
3001 st = next_statement ();
3007 for (p = gfc_state_stack; p; p = p->previous)
3008 if (p->state == COMP_CONTAINS)
3011 if (gfc_find_state (COMP_MODULE) == SUCCESS)
3016 gfc_error ("CONTAINS statement at %C is already in a contained "
3018 st = next_statement ();
3022 parse_contained (0);
3025 gfc_current_ns->code = gfc_state_stack->head;
3029 /* Come here to complain about a global symbol already in use as
3033 global_used (gfc_gsymbol *sym, locus *where)
3038 where = &gfc_current_locus;
3048 case GSYM_SUBROUTINE:
3049 name = "SUBROUTINE";
3054 case GSYM_BLOCK_DATA:
3055 name = "BLOCK DATA";
3061 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3065 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3066 sym->name, where, name, &sym->where);
3070 /* Parse a block data program unit. */
3073 parse_block_data (void)
3076 static locus blank_locus;
3077 static int blank_block=0;
3080 gfc_current_ns->proc_name = gfc_new_block;
3081 gfc_current_ns->is_block_data = 1;
3083 if (gfc_new_block == NULL)
3086 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3087 "prior BLOCK DATA at %L", &blank_locus);
3091 blank_locus = gfc_current_locus;
3096 s = gfc_get_gsymbol (gfc_new_block->name);
3098 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3099 global_used(s, NULL);
3102 s->type = GSYM_BLOCK_DATA;
3103 s->where = gfc_current_locus;
3108 st = parse_spec (ST_NONE);
3110 while (st != ST_END_BLOCK_DATA)
3112 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3113 gfc_ascii_statement (st));
3114 reject_statement ();
3115 st = next_statement ();
3120 /* Parse a module subprogram. */
3128 s = gfc_get_gsymbol (gfc_new_block->name);
3129 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3130 global_used(s, NULL);
3133 s->type = GSYM_MODULE;
3134 s->where = gfc_current_locus;
3138 st = parse_spec (ST_NONE);
3147 parse_contained (1);
3151 accept_statement (st);
3155 gfc_error ("Unexpected %s statement in MODULE at %C",
3156 gfc_ascii_statement (st));
3158 reject_statement ();
3159 st = next_statement ();
3165 /* Add a procedure name to the global symbol table. */
3168 add_global_procedure (int sub)
3172 s = gfc_get_gsymbol(gfc_new_block->name);
3175 || (s->type != GSYM_UNKNOWN
3176 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3177 global_used(s, NULL);
3180 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3181 s->where = gfc_current_locus;
3187 /* Add a program to the global symbol table. */
3190 add_global_program (void)
3194 if (gfc_new_block == NULL)
3196 s = gfc_get_gsymbol (gfc_new_block->name);
3198 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3199 global_used(s, NULL);
3202 s->type = GSYM_PROGRAM;
3203 s->where = gfc_current_locus;
3209 /* Top level parser. */
3212 gfc_parse_file (void)
3214 int seen_program, errors_before, errors;
3215 gfc_state_data top, s;
3219 top.state = COMP_NONE;
3221 top.previous = NULL;
3222 top.head = top.tail = NULL;
3223 top.do_variable = NULL;
3225 gfc_state_stack = ⊤
3227 gfc_clear_new_st ();
3229 gfc_statement_label = NULL;
3231 if (setjmp (eof_buf))
3232 return FAILURE; /* Come here on unexpected EOF */
3236 /* Exit early for empty files. */
3242 st = next_statement ();
3251 goto duplicate_main;
3253 prog_locus = gfc_current_locus;
3255 push_state (&s, COMP_PROGRAM, gfc_new_block);
3256 main_program_symbol(gfc_current_ns);
3257 accept_statement (st);
3258 add_global_program ();
3259 parse_progunit (ST_NONE);
3263 add_global_procedure (1);
3264 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3265 accept_statement (st);
3266 parse_progunit (ST_NONE);
3270 add_global_procedure (0);
3271 push_state (&s, COMP_FUNCTION, gfc_new_block);
3272 accept_statement (st);
3273 parse_progunit (ST_NONE);
3277 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3278 accept_statement (st);
3279 parse_block_data ();
3283 push_state (&s, COMP_MODULE, gfc_new_block);
3284 accept_statement (st);
3286 gfc_get_errors (NULL, &errors_before);
3290 /* Anything else starts a nameless main program block. */
3293 goto duplicate_main;
3295 prog_locus = gfc_current_locus;
3297 push_state (&s, COMP_PROGRAM, gfc_new_block);
3298 main_program_symbol (gfc_current_ns);
3299 parse_progunit (st);
3303 gfc_current_ns->code = s.head;
3305 gfc_resolve (gfc_current_ns);
3307 /* Dump the parse tree if requested. */
3308 if (gfc_option.verbose)
3309 gfc_show_namespace (gfc_current_ns);
3311 gfc_get_errors (NULL, &errors);
3312 if (s.state == COMP_MODULE)
3314 gfc_dump_module (s.sym->name, errors_before == errors);
3316 gfc_generate_module_code (gfc_current_ns);
3321 gfc_generate_code (gfc_current_ns);
3332 /* If we see a duplicate main program, shut down. If the second
3333 instance is an implied main program, ie data decls or executable
3334 statements, we're in for lots of errors. */
3335 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3336 reject_statement ();