2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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/>. */
30 /* Current statement label. Zero means no statement label. Because new_st
31 can get wiped during statement matching, we have to keep it separate. */
33 gfc_st_label *gfc_statement_label;
35 static locus label_locus;
36 static jmp_buf eof_buf;
38 gfc_state_data *gfc_state_stack;
40 /* TODO: Re-order functions to kill these forward decls. */
41 static void check_statement_label (gfc_statement);
42 static void undo_new_statement (void);
43 static void reject_statement (void);
46 /* A sort of half-matching function. We try to match the word on the
47 input with the passed string. If this succeeds, we call the
48 keyword-dependent matching function that will match the rest of the
49 statement. For single keywords, the matching subroutine is
53 match_word (const char *str, match (*subr) (void), locus *old_locus)
68 gfc_current_locus = *old_locus;
76 /* Figure out what the next statement is, (mostly) regardless of
77 proper ordering. The do...while(0) is there to prevent if/else
80 #define match(keyword, subr, st) \
82 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
85 undo_new_statement (); \
89 /* This is a specialist version of decode_statement that is used
90 for the specification statements in a function, whose
91 characteristics are deferred into the specification statements.
92 eg.: INTEGER (king = mykind) foo ()
93 USE mymodule, ONLY mykind.....
94 The KIND parameter needs a return after USE or IMPORT, whereas
95 derived type declarations can occur anywhere, up the executable
96 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
97 out of the correct kind of specification statements. */
99 decode_specification_statement (void)
105 if (gfc_match_eos () == MATCH_YES)
108 old_locus = gfc_current_locus;
110 match ("import", gfc_match_import, ST_IMPORT);
111 match ("use", gfc_match_use, ST_USE);
113 if (gfc_current_block ()->ts.type != BT_DERIVED)
116 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
117 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
118 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
120 /* General statement matching: Instead of testing every possible
121 statement, we eliminate most possibilities by peeking at the
124 c = gfc_peek_ascii_char ();
129 match ("abstract% interface", gfc_match_abstract_interface,
134 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
141 match ("data", gfc_match_data, ST_DATA);
142 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
146 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
147 match ("entry% ", gfc_match_entry, ST_ENTRY);
148 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
149 match ("external", gfc_match_external, ST_ATTR_DECL);
153 match ("format", gfc_match_format, ST_FORMAT);
160 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
161 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
162 match ("interface", gfc_match_interface, ST_INTERFACE);
163 match ("intent", gfc_match_intent, ST_ATTR_DECL);
164 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
171 match ("namelist", gfc_match_namelist, ST_NAMELIST);
175 match ("optional", gfc_match_optional, ST_ATTR_DECL);
179 match ("parameter", gfc_match_parameter, ST_PARAMETER);
180 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
181 if (gfc_match_private (&st) == MATCH_YES)
183 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
184 if (gfc_match_public (&st) == MATCH_YES)
186 match ("protected", gfc_match_protected, ST_ATTR_DECL);
193 match ("save", gfc_match_save, ST_ATTR_DECL);
197 match ("target", gfc_match_target, ST_ATTR_DECL);
198 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
205 match ("value", gfc_match_value, ST_ATTR_DECL);
206 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
213 /* This is not a specification statement. See if any of the matchers
214 has stored an error message of some sort. */
218 gfc_buffer_error (0);
219 gfc_current_locus = old_locus;
221 return ST_GET_FCN_CHARACTERISTICS;
225 /* This is the primary 'decode_statement'. */
227 decode_statement (void)
238 gfc_clear_error (); /* Clear any pending errors. */
239 gfc_clear_warning (); /* Clear any pending warnings. */
241 gfc_matching_function = false;
243 if (gfc_match_eos () == MATCH_YES)
246 if (gfc_current_state () == COMP_FUNCTION
247 && gfc_current_block ()->result->ts.kind == -1)
248 return decode_specification_statement ();
250 old_locus = gfc_current_locus;
252 /* Try matching a data declaration or function declaration. The
253 input "REALFUNCTIONA(N)" can mean several things in different
254 contexts, so it (and its relatives) get special treatment. */
256 if (gfc_current_state () == COMP_NONE
257 || gfc_current_state () == COMP_INTERFACE
258 || gfc_current_state () == COMP_CONTAINS)
260 gfc_matching_function = true;
261 m = gfc_match_function_decl ();
264 else if (m == MATCH_ERROR)
268 gfc_current_locus = old_locus;
270 gfc_matching_function = false;
273 /* Match statements whose error messages are meant to be overwritten
274 by something better. */
276 match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
277 match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
278 match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
280 match (NULL, gfc_match_data_decl, ST_DATA_DECL);
281 match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
283 /* Try to match a subroutine statement, which has the same optional
284 prefixes that functions can have. */
286 if (gfc_match_subroutine () == MATCH_YES)
287 return ST_SUBROUTINE;
289 gfc_current_locus = old_locus;
291 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
292 might begin with a block label. The match functions for these
293 statements are unusual in that their keyword is not seen before
294 the matcher is called. */
296 if (gfc_match_if (&st) == MATCH_YES)
299 gfc_current_locus = old_locus;
301 if (gfc_match_where (&st) == MATCH_YES)
304 gfc_current_locus = old_locus;
306 if (gfc_match_forall (&st) == MATCH_YES)
309 gfc_current_locus = old_locus;
311 match (NULL, gfc_match_do, ST_DO);
312 match (NULL, gfc_match_select, ST_SELECT_CASE);
314 /* General statement matching: Instead of testing every possible
315 statement, we eliminate most possibilities by peeking at the
318 c = gfc_peek_ascii_char ();
323 match ("abstract% interface", gfc_match_abstract_interface,
325 match ("allocate", gfc_match_allocate, ST_ALLOCATE);
326 match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
327 match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
331 match ("backspace", gfc_match_backspace, ST_BACKSPACE);
332 match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
333 match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
337 match ("call", gfc_match_call, ST_CALL);
338 match ("close", gfc_match_close, ST_CLOSE);
339 match ("continue", gfc_match_continue, ST_CONTINUE);
340 match ("cycle", gfc_match_cycle, ST_CYCLE);
341 match ("case", gfc_match_case, ST_CASE);
342 match ("common", gfc_match_common, ST_COMMON);
343 match ("contains", gfc_match_eos, ST_CONTAINS);
347 match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
348 match ("data", gfc_match_data, ST_DATA);
349 match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
353 match ("end file", gfc_match_endfile, ST_END_FILE);
354 match ("exit", gfc_match_exit, ST_EXIT);
355 match ("else", gfc_match_else, ST_ELSE);
356 match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
357 match ("else if", gfc_match_elseif, ST_ELSEIF);
358 match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
360 if (gfc_match_end (&st) == MATCH_YES)
363 match ("entry% ", gfc_match_entry, ST_ENTRY);
364 match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
365 match ("external", gfc_match_external, ST_ATTR_DECL);
369 match ("flush", gfc_match_flush, ST_FLUSH);
370 match ("format", gfc_match_format, ST_FORMAT);
374 match ("go to", gfc_match_goto, ST_GOTO);
378 match ("inquire", gfc_match_inquire, ST_INQUIRE);
379 match ("implicit", gfc_match_implicit, ST_IMPLICIT);
380 match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
381 match ("import", gfc_match_import, ST_IMPORT);
382 match ("interface", gfc_match_interface, ST_INTERFACE);
383 match ("intent", gfc_match_intent, ST_ATTR_DECL);
384 match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
388 match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
389 match ("module", gfc_match_module, ST_MODULE);
393 match ("nullify", gfc_match_nullify, ST_NULLIFY);
394 match ("namelist", gfc_match_namelist, ST_NAMELIST);
398 match ("open", gfc_match_open, ST_OPEN);
399 match ("optional", gfc_match_optional, ST_ATTR_DECL);
403 match ("print", gfc_match_print, ST_WRITE);
404 match ("parameter", gfc_match_parameter, ST_PARAMETER);
405 match ("pause", gfc_match_pause, ST_PAUSE);
406 match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
407 if (gfc_match_private (&st) == MATCH_YES)
409 match ("procedure", gfc_match_procedure, ST_PROCEDURE);
410 match ("program", gfc_match_program, ST_PROGRAM);
411 if (gfc_match_public (&st) == MATCH_YES)
413 match ("protected", gfc_match_protected, ST_ATTR_DECL);
417 match ("read", gfc_match_read, ST_READ);
418 match ("return", gfc_match_return, ST_RETURN);
419 match ("rewind", gfc_match_rewind, ST_REWIND);
423 match ("sequence", gfc_match_eos, ST_SEQUENCE);
424 match ("stop", gfc_match_stop, ST_STOP);
425 match ("save", gfc_match_save, ST_ATTR_DECL);
429 match ("target", gfc_match_target, ST_ATTR_DECL);
430 match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
434 match ("use", gfc_match_use, ST_USE);
438 match ("value", gfc_match_value, ST_ATTR_DECL);
439 match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
443 match ("wait", gfc_match_wait, ST_WAIT);
444 match ("write", gfc_match_write, ST_WRITE);
448 /* All else has failed, so give up. See if any of the matchers has
449 stored an error message of some sort. */
451 if (gfc_error_check () == 0)
452 gfc_error_now ("Unclassifiable statement at %C");
456 gfc_error_recovery ();
462 decode_omp_directive (void)
471 gfc_clear_error (); /* Clear any pending errors. */
472 gfc_clear_warning (); /* Clear any pending warnings. */
476 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
477 "or ELEMENTAL procedures");
478 gfc_error_recovery ();
482 old_locus = gfc_current_locus;
484 /* General OpenMP directive matching: Instead of testing every possible
485 statement, we eliminate most possibilities by peeking at the
488 c = gfc_peek_ascii_char ();
493 match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
496 match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
499 match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
502 match ("do", gfc_match_omp_do, ST_OMP_DO);
505 match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
506 match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
507 match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
508 match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
509 match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
510 match ("end parallel sections", gfc_match_omp_eos,
511 ST_OMP_END_PARALLEL_SECTIONS);
512 match ("end parallel workshare", gfc_match_omp_eos,
513 ST_OMP_END_PARALLEL_WORKSHARE);
514 match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
515 match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
516 match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
517 match ("end workshare", gfc_match_omp_end_nowait,
518 ST_OMP_END_WORKSHARE);
521 match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
524 match ("master", gfc_match_omp_master, ST_OMP_MASTER);
527 match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
530 match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
531 match ("parallel sections", gfc_match_omp_parallel_sections,
532 ST_OMP_PARALLEL_SECTIONS);
533 match ("parallel workshare", gfc_match_omp_parallel_workshare,
534 ST_OMP_PARALLEL_WORKSHARE);
535 match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
538 match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
539 match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
540 match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
543 match ("threadprivate", gfc_match_omp_threadprivate,
544 ST_OMP_THREADPRIVATE);
546 match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
550 /* All else has failed, so give up. See if any of the matchers has
551 stored an error message of some sort. */
553 if (gfc_error_check () == 0)
554 gfc_error_now ("Unclassifiable OpenMP directive at %C");
558 gfc_error_recovery ();
566 /* Get the next statement in free form source. */
575 at_bol = gfc_at_bol ();
576 gfc_gobble_whitespace ();
578 c = gfc_peek_ascii_char ();
584 /* Found a statement label? */
585 m = gfc_match_st_label (&gfc_statement_label);
587 d = gfc_peek_ascii_char ();
588 if (m != MATCH_YES || !gfc_is_whitespace (d))
590 gfc_match_small_literal_int (&i, &cnt);
593 gfc_error_now ("Too many digits in statement label at %C");
596 gfc_error_now ("Zero is not a valid statement label at %C");
599 c = gfc_next_ascii_char ();
602 if (!gfc_is_whitespace (c))
603 gfc_error_now ("Non-numeric character in statement label at %C");
609 label_locus = gfc_current_locus;
611 gfc_gobble_whitespace ();
613 if (at_bol && gfc_peek_ascii_char () == ';')
615 gfc_error_now ("Semicolon at %C needs to be preceded by "
617 gfc_next_ascii_char (); /* Eat up the semicolon. */
621 if (gfc_match_eos () == MATCH_YES)
623 gfc_warning_now ("Ignoring statement label in empty statement "
625 gfc_free_st_label (gfc_statement_label);
626 gfc_statement_label = NULL;
633 /* Comments have already been skipped by the time we get here,
634 except for OpenMP directives. */
635 if (gfc_option.flag_openmp)
639 c = gfc_next_ascii_char ();
640 for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
641 gcc_assert (c == "!$omp"[i]);
643 gcc_assert (c == ' ');
644 gfc_gobble_whitespace ();
645 return decode_omp_directive ();
649 if (at_bol && c == ';')
651 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
652 gfc_next_ascii_char (); /* Eat up the semicolon. */
656 return decode_statement ();
660 /* Get the next statement in fixed-form source. */
665 int label, digit_flag, i;
670 return decode_statement ();
672 /* Skip past the current label field, parsing a statement label if
673 one is there. This is a weird number parser, since the number is
674 contained within five columns and can have any kind of embedded
675 spaces. We also check for characters that make the rest of the
681 for (i = 0; i < 5; i++)
683 c = gfc_next_char_literal (0);
700 label = label * 10 + ((unsigned char) c - '0');
701 label_locus = gfc_current_locus;
705 /* Comments have already been skipped by the time we get
706 here, except for OpenMP directives. */
708 if (gfc_option.flag_openmp)
710 for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
711 gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
713 if (c != ' ' && c != '0')
715 gfc_buffer_error (0);
716 gfc_error ("Bad continuation line at %C");
720 return decode_omp_directive ();
724 /* Comments have already been skipped by the time we get
725 here so don't bother checking for them. */
728 gfc_buffer_error (0);
729 gfc_error ("Non-numeric character in statement label at %C");
737 gfc_warning_now ("Zero is not a valid statement label at %C");
740 /* We've found a valid statement label. */
741 gfc_statement_label = gfc_get_st_label (label);
745 /* Since this line starts a statement, it cannot be a continuation
746 of a previous statement. If we see something here besides a
747 space or zero, it must be a bad continuation line. */
749 c = gfc_next_char_literal (0);
753 if (c != ' ' && c != '0')
755 gfc_buffer_error (0);
756 gfc_error ("Bad continuation line at %C");
760 /* Now that we've taken care of the statement label columns, we have
761 to make sure that the first nonblank character is not a '!'. If
762 it is, the rest of the line is a comment. */
766 loc = gfc_current_locus;
767 c = gfc_next_char_literal (0);
769 while (gfc_is_whitespace (c));
773 gfc_current_locus = loc;
777 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
781 if (gfc_match_eos () == MATCH_YES)
784 /* At this point, we've got a nonblank statement to parse. */
785 return decode_statement ();
789 gfc_warning ("Ignoring statement label in empty statement at %C");
795 /* Return the next non-ST_NONE statement to the caller. We also worry
796 about including files and the ends of include files at this stage. */
799 next_statement (void)
803 gfc_new_block = NULL;
807 gfc_statement_label = NULL;
808 gfc_buffer_error (1);
812 if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
813 && gfc_current_locus.lb
814 && gfc_current_locus.lb->truncated)
815 gfc_warning_now ("Line truncated at %C");
820 gfc_skip_comments ();
828 if (gfc_define_undef_line ())
831 old_locus = gfc_current_locus;
833 st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
839 gfc_buffer_error (0);
841 if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
843 gfc_free_st_label (gfc_statement_label);
844 gfc_statement_label = NULL;
845 gfc_current_locus = old_locus;
849 check_statement_label (st);
855 /****************************** Parser ***********************************/
857 /* The parser subroutines are of type 'try' that fail if the file ends
860 /* Macros that expand to case-labels for various classes of
861 statements. Start with executable statements that directly do
864 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
865 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
866 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
867 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
868 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
869 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
870 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
871 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
874 /* Statements that mark other executable statements. */
876 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
877 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
878 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
879 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
880 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
881 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
883 /* Declaration statements */
885 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
886 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
887 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
890 /* Block end statements. Errors associated with interchanging these
891 are detected in gfc_match_end(). */
893 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
894 case ST_END_PROGRAM: case ST_END_SUBROUTINE
897 /* Push a new state onto the stack. */
900 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
902 p->state = new_state;
903 p->previous = gfc_state_stack;
905 p->head = p->tail = NULL;
906 p->do_variable = NULL;
911 /* Pop the current state. */
915 gfc_state_stack = gfc_state_stack->previous;
919 /* Try to find the given state in the state stack. */
922 gfc_find_state (gfc_compile_state state)
926 for (p = gfc_state_stack; p; p = p->previous)
927 if (p->state == state)
930 return (p == NULL) ? FAILURE : SUCCESS;
934 /* Starts a new level in the statement list. */
937 new_level (gfc_code *q)
941 p = q->block = gfc_get_code ();
943 gfc_state_stack->head = gfc_state_stack->tail = p;
949 /* Add the current new_st code structure and adds it to the current
950 program unit. As a side-effect, it zeroes the new_st. */
960 p->loc = gfc_current_locus;
962 if (gfc_state_stack->head == NULL)
963 gfc_state_stack->head = p;
965 gfc_state_stack->tail->next = p;
967 while (p->next != NULL)
970 gfc_state_stack->tail = p;
978 /* Frees everything associated with the current statement. */
981 undo_new_statement (void)
983 gfc_free_statements (new_st.block);
984 gfc_free_statements (new_st.next);
985 gfc_free_statement (&new_st);
990 /* If the current statement has a statement label, make sure that it
991 is allowed to, or should have one. */
994 check_statement_label (gfc_statement st)
998 if (gfc_statement_label == NULL)
1000 if (st == ST_FORMAT)
1001 gfc_error ("FORMAT statement at %L does not have a statement label",
1008 case ST_END_PROGRAM:
1009 case ST_END_FUNCTION:
1010 case ST_END_SUBROUTINE:
1016 type = ST_LABEL_TARGET;
1020 type = ST_LABEL_FORMAT;
1023 /* Statement labels are not restricted from appearing on a
1024 particular line. However, there are plenty of situations
1025 where the resulting label can't be referenced. */
1028 type = ST_LABEL_BAD_TARGET;
1032 gfc_define_st_label (gfc_statement_label, type, &label_locus);
1034 new_st.here = gfc_statement_label;
1038 /* Figures out what the enclosing program unit is. This will be a
1039 function, subroutine, program, block data or module. */
1042 gfc_enclosing_unit (gfc_compile_state * result)
1046 for (p = gfc_state_stack; p; p = p->previous)
1047 if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1048 || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1049 || p->state == COMP_PROGRAM)
1058 *result = COMP_PROGRAM;
1063 /* Translate a statement enum to a string. */
1066 gfc_ascii_statement (gfc_statement st)
1072 case ST_ARITHMETIC_IF:
1073 p = _("arithmetic IF");
1079 p = _("attribute declaration");
1109 p = _("data declaration");
1117 case ST_DERIVED_DECL:
1118 p = _("derived type declaration");
1132 case ST_END_BLOCK_DATA:
1133 p = "END BLOCK DATA";
1144 case ST_END_FUNCTION:
1150 case ST_END_INTERFACE:
1151 p = "END INTERFACE";
1156 case ST_END_PROGRAM:
1162 case ST_END_SUBROUTINE:
1163 p = "END SUBROUTINE";
1174 case ST_EQUIVALENCE:
1183 case ST_FORALL_BLOCK: /* Fall through */
1202 case ST_IMPLICIT_NONE:
1203 p = "IMPLICIT NONE";
1205 case ST_IMPLIED_ENDDO:
1206 p = _("implied END DO");
1232 case ST_MODULE_PROC:
1233 p = "MODULE PROCEDURE";
1271 case ST_WHERE_BLOCK: /* Fall through */
1282 p = _("assignment");
1284 case ST_POINTER_ASSIGNMENT:
1285 p = _("pointer assignment");
1287 case ST_SELECT_CASE:
1296 case ST_STATEMENT_FUNCTION:
1297 p = "STATEMENT FUNCTION";
1299 case ST_LABEL_ASSIGNMENT:
1300 p = "LABEL ASSIGNMENT";
1303 p = "ENUM DEFINITION";
1306 p = "ENUMERATOR DEFINITION";
1314 case ST_OMP_BARRIER:
1315 p = "!$OMP BARRIER";
1317 case ST_OMP_CRITICAL:
1318 p = "!$OMP CRITICAL";
1323 case ST_OMP_END_CRITICAL:
1324 p = "!$OMP END CRITICAL";
1329 case ST_OMP_END_MASTER:
1330 p = "!$OMP END MASTER";
1332 case ST_OMP_END_ORDERED:
1333 p = "!$OMP END ORDERED";
1335 case ST_OMP_END_PARALLEL:
1336 p = "!$OMP END PARALLEL";
1338 case ST_OMP_END_PARALLEL_DO:
1339 p = "!$OMP END PARALLEL DO";
1341 case ST_OMP_END_PARALLEL_SECTIONS:
1342 p = "!$OMP END PARALLEL SECTIONS";
1344 case ST_OMP_END_PARALLEL_WORKSHARE:
1345 p = "!$OMP END PARALLEL WORKSHARE";
1347 case ST_OMP_END_SECTIONS:
1348 p = "!$OMP END SECTIONS";
1350 case ST_OMP_END_SINGLE:
1351 p = "!$OMP END SINGLE";
1353 case ST_OMP_END_WORKSHARE:
1354 p = "!$OMP END WORKSHARE";
1362 case ST_OMP_ORDERED:
1363 p = "!$OMP ORDERED";
1365 case ST_OMP_PARALLEL:
1366 p = "!$OMP PARALLEL";
1368 case ST_OMP_PARALLEL_DO:
1369 p = "!$OMP PARALLEL DO";
1371 case ST_OMP_PARALLEL_SECTIONS:
1372 p = "!$OMP PARALLEL SECTIONS";
1374 case ST_OMP_PARALLEL_WORKSHARE:
1375 p = "!$OMP PARALLEL WORKSHARE";
1377 case ST_OMP_SECTIONS:
1378 p = "!$OMP SECTIONS";
1380 case ST_OMP_SECTION:
1381 p = "!$OMP SECTION";
1386 case ST_OMP_THREADPRIVATE:
1387 p = "!$OMP THREADPRIVATE";
1389 case ST_OMP_WORKSHARE:
1390 p = "!$OMP WORKSHARE";
1393 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1400 /* Create a symbol for the main program and assign it to ns->proc_name. */
1403 main_program_symbol (gfc_namespace *ns, const char *name)
1405 gfc_symbol *main_program;
1406 symbol_attribute attr;
1408 gfc_get_symbol (name, ns, &main_program);
1409 gfc_clear_attr (&attr);
1410 attr.flavor = FL_PROGRAM;
1411 attr.proc = PROC_UNKNOWN;
1412 attr.subroutine = 1;
1413 attr.access = ACCESS_PUBLIC;
1414 attr.is_main_program = 1;
1415 main_program->attr = attr;
1416 main_program->declared_at = gfc_current_locus;
1417 ns->proc_name = main_program;
1418 gfc_commit_symbols ();
1422 /* Do whatever is necessary to accept the last statement. */
1425 accept_statement (gfc_statement st)
1433 case ST_IMPLICIT_NONE:
1434 gfc_set_implicit_none ();
1443 gfc_current_ns->proc_name = gfc_new_block;
1446 /* If the statement is the end of a block, lay down a special code
1447 that allows a branch to the end of the block from within the
1452 if (gfc_statement_label != NULL)
1454 new_st.op = EXEC_NOP;
1460 /* The end-of-program unit statements do not get the special
1461 marker and require a statement of some sort if they are a
1464 case ST_END_PROGRAM:
1465 case ST_END_FUNCTION:
1466 case ST_END_SUBROUTINE:
1467 if (gfc_statement_label != NULL)
1469 new_st.op = EXEC_RETURN;
1485 gfc_commit_symbols ();
1486 gfc_warning_check ();
1487 gfc_clear_new_st ();
1491 /* Undo anything tentative that has been built for the current
1495 reject_statement (void)
1497 gfc_new_block = NULL;
1498 gfc_undo_symbols ();
1499 gfc_clear_warning ();
1500 undo_new_statement ();
1504 /* Generic complaint about an out of order statement. We also do
1505 whatever is necessary to clean up. */
1508 unexpected_statement (gfc_statement st)
1510 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1512 reject_statement ();
1516 /* Given the next statement seen by the matcher, make sure that it is
1517 in proper order with the last. This subroutine is initialized by
1518 calling it with an argument of ST_NONE. If there is a problem, we
1519 issue an error and return FAILURE. Otherwise we return SUCCESS.
1521 Individual parsers need to verify that the statements seen are
1522 valid before calling here, ie ENTRY statements are not allowed in
1523 INTERFACE blocks. The following diagram is taken from the standard:
1525 +---------------------------------------+
1526 | program subroutine function module |
1527 +---------------------------------------+
1529 +---------------------------------------+
1531 +---------------------------------------+
1533 | +-----------+------------------+
1534 | | parameter | implicit |
1535 | +-----------+------------------+
1536 | format | | derived type |
1537 | entry | parameter | interface |
1538 | | data | specification |
1539 | | | statement func |
1540 | +-----------+------------------+
1541 | | data | executable |
1542 +--------+-----------+------------------+
1544 +---------------------------------------+
1545 | internal module/subprogram |
1546 +---------------------------------------+
1548 +---------------------------------------+
1555 { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
1556 ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
1559 gfc_statement last_statement;
1565 verify_st_order (st_state *p, gfc_statement st)
1571 p->state = ORDER_START;
1575 if (p->state > ORDER_USE)
1577 p->state = ORDER_USE;
1581 if (p->state > ORDER_IMPORT)
1583 p->state = ORDER_IMPORT;
1586 case ST_IMPLICIT_NONE:
1587 if (p->state > ORDER_IMPLICIT_NONE)
1590 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1591 statement disqualifies a USE but not an IMPLICIT NONE.
1592 Duplicate IMPLICIT NONEs are caught when the implicit types
1595 p->state = ORDER_IMPLICIT_NONE;
1599 if (p->state > ORDER_IMPLICIT)
1601 p->state = ORDER_IMPLICIT;
1606 if (p->state < ORDER_IMPLICIT_NONE)
1607 p->state = ORDER_IMPLICIT_NONE;
1611 if (p->state >= ORDER_EXEC)
1613 if (p->state < ORDER_IMPLICIT)
1614 p->state = ORDER_IMPLICIT;
1618 if (p->state < ORDER_SPEC)
1619 p->state = ORDER_SPEC;
1624 case ST_DERIVED_DECL:
1626 if (p->state >= ORDER_EXEC)
1628 if (p->state < ORDER_SPEC)
1629 p->state = ORDER_SPEC;
1634 if (p->state < ORDER_EXEC)
1635 p->state = ORDER_EXEC;
1639 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1640 gfc_ascii_statement (st));
1643 /* All is well, record the statement in case we need it next time. */
1644 p->where = gfc_current_locus;
1645 p->last_statement = st;
1649 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1650 gfc_ascii_statement (st),
1651 gfc_ascii_statement (p->last_statement), &p->where);
1657 /* Handle an unexpected end of file. This is a show-stopper... */
1659 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1662 unexpected_eof (void)
1666 gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1668 /* Memory cleanup. Move to "second to last". */
1669 for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1672 gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1675 longjmp (eof_buf, 1);
1679 /* Parse a derived type. */
1682 parse_derived (void)
1684 int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1687 gfc_symbol *derived_sym = NULL;
1693 accept_statement (ST_DERIVED_DECL);
1694 push_state (&s, COMP_DERIVED, gfc_new_block);
1696 gfc_new_block->component_access = ACCESS_PUBLIC;
1703 while (compiling_type)
1705 st = next_statement ();
1713 accept_statement (st);
1721 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
1722 "definition at %C without components")
1726 accept_statement (ST_END_TYPE);
1730 if (gfc_find_state (COMP_MODULE) == FAILURE)
1732 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1740 gfc_error ("PRIVATE statement at %C must precede "
1741 "structure components");
1748 gfc_error ("Duplicate PRIVATE statement at %C");
1752 s.sym->component_access = ACCESS_PRIVATE;
1753 accept_statement (ST_PRIVATE);
1760 gfc_error ("SEQUENCE statement at %C must precede "
1761 "structure components");
1766 if (gfc_current_block ()->attr.sequence)
1767 gfc_warning ("SEQUENCE attribute at %C already specified in "
1772 gfc_error ("Duplicate SEQUENCE statement at %C");
1777 gfc_add_sequence (&gfc_current_block ()->attr,
1778 gfc_current_block ()->name, NULL);
1782 unexpected_statement (st);
1787 /* need to verify that all fields of the derived type are
1788 * interoperable with C if the type is declared to be bind(c)
1790 derived_sym = gfc_current_block();
1792 sym = gfc_current_block ();
1793 for (c = sym->components; c; c = c->next)
1795 /* Look for allocatable components. */
1797 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
1799 sym->attr.alloc_comp = 1;
1803 /* Look for pointer components. */
1805 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
1807 sym->attr.pointer_comp = 1;
1811 /* Look for private components. */
1812 if (sym->component_access == ACCESS_PRIVATE
1813 || c->access == ACCESS_PRIVATE
1814 || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
1816 sym->attr.private_comp = 1;
1821 if (!seen_component)
1822 sym->attr.zero_comp = 1;
1828 /* Parse an ENUM. */
1837 int seen_enumerator = 0;
1841 push_state (&s, COMP_ENUM, gfc_new_block);
1845 while (compiling_enum)
1847 st = next_statement ();
1855 seen_enumerator = 1;
1856 accept_statement (st);
1861 if (!seen_enumerator)
1863 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1866 accept_statement (st);
1870 gfc_free_enum_history ();
1871 unexpected_statement (st);
1879 /* Parse an interface. We must be able to deal with the possibility
1880 of recursive interfaces. The parse_spec() subroutine is mutually
1881 recursive with parse_interface(). */
1883 static gfc_statement parse_spec (gfc_statement);
1886 parse_interface (void)
1888 gfc_compile_state new_state, current_state;
1889 gfc_symbol *prog_unit, *sym;
1890 gfc_interface_info save;
1891 gfc_state_data s1, s2;
1895 accept_statement (ST_INTERFACE);
1897 current_interface.ns = gfc_current_ns;
1898 save = current_interface;
1900 sym = (current_interface.type == INTERFACE_GENERIC
1901 || current_interface.type == INTERFACE_USER_OP)
1902 ? gfc_new_block : NULL;
1904 push_state (&s1, COMP_INTERFACE, sym);
1905 current_state = COMP_NONE;
1908 gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1910 st = next_statement ();
1917 new_state = COMP_SUBROUTINE;
1918 gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1919 gfc_new_block->formal, NULL);
1920 if (current_interface.type != INTERFACE_ABSTRACT &&
1921 !gfc_new_block->attr.dummy &&
1922 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
1924 reject_statement ();
1925 gfc_free_namespace (gfc_current_ns);
1931 new_state = COMP_FUNCTION;
1932 gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1933 gfc_new_block->formal, NULL);
1934 if (current_interface.type != INTERFACE_ABSTRACT &&
1935 !gfc_new_block->attr.dummy &&
1936 gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
1938 reject_statement ();
1939 gfc_free_namespace (gfc_current_ns);
1945 case ST_MODULE_PROC: /* The module procedure matcher makes
1946 sure the context is correct. */
1947 accept_statement (st);
1948 gfc_free_namespace (gfc_current_ns);
1951 case ST_END_INTERFACE:
1952 gfc_free_namespace (gfc_current_ns);
1953 gfc_current_ns = current_interface.ns;
1957 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1958 gfc_ascii_statement (st));
1959 reject_statement ();
1960 gfc_free_namespace (gfc_current_ns);
1965 /* Make sure that a generic interface has only subroutines or
1966 functions and that the generic name has the right attribute. */
1967 if (current_interface.type == INTERFACE_GENERIC)
1969 if (current_state == COMP_NONE)
1971 if (new_state == COMP_FUNCTION)
1972 gfc_add_function (&sym->attr, sym->name, NULL);
1973 else if (new_state == COMP_SUBROUTINE)
1974 gfc_add_subroutine (&sym->attr, sym->name, NULL);
1976 current_state = new_state;
1980 if (new_state != current_state)
1982 if (new_state == COMP_SUBROUTINE)
1983 gfc_error ("SUBROUTINE at %C does not belong in a "
1984 "generic function interface");
1986 if (new_state == COMP_FUNCTION)
1987 gfc_error ("FUNCTION at %C does not belong in a "
1988 "generic subroutine interface");
1993 if (current_interface.type == INTERFACE_ABSTRACT)
1995 gfc_new_block->attr.abstract = 1;
1996 if (gfc_is_intrinsic_typename (gfc_new_block->name))
1997 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1998 "cannot be the same as an intrinsic type",
1999 gfc_new_block->name);
2002 push_state (&s2, new_state, gfc_new_block);
2003 accept_statement (st);
2004 prog_unit = gfc_new_block;
2005 prog_unit->formal_ns = gfc_current_ns;
2006 proc_locus = gfc_current_locus;
2009 /* Read data declaration statements. */
2010 st = parse_spec (ST_NONE);
2012 /* Since the interface block does not permit an IMPLICIT statement,
2013 the default type for the function or the result must be taken
2014 from the formal namespace. */
2015 if (new_state == COMP_FUNCTION)
2017 if (prog_unit->result == prog_unit
2018 && prog_unit->ts.type == BT_UNKNOWN)
2019 gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2020 else if (prog_unit->result != prog_unit
2021 && prog_unit->result->ts.type == BT_UNKNOWN)
2022 gfc_set_default_type (prog_unit->result, 1,
2023 prog_unit->formal_ns);
2026 if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2028 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2029 gfc_ascii_statement (st));
2030 reject_statement ();
2034 current_interface = save;
2035 gfc_add_interface (prog_unit);
2038 if (current_interface.ns
2039 && current_interface.ns->proc_name
2040 && strcmp (current_interface.ns->proc_name->name,
2041 prog_unit->name) == 0)
2042 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2043 "enclosing procedure", prog_unit->name, &proc_locus);
2052 /* Associate function characteristics by going back to the function
2053 declaration and rematching the prefix. */
2056 match_deferred_characteristics (gfc_typespec * ts)
2059 match m = MATCH_ERROR;
2060 char name[GFC_MAX_SYMBOL_LEN + 1];
2062 loc = gfc_current_locus;
2064 gfc_current_locus = gfc_current_block ()->declared_at;
2067 gfc_buffer_error (1);
2068 m = gfc_match_prefix (ts);
2069 gfc_buffer_error (0);
2071 if (ts->type == BT_DERIVED)
2075 if (!ts->derived || !ts->derived->components)
2079 /* Only permit one go at the characteristic association. */
2083 /* Set the function locus correctly. If we have not found the
2084 function name, there is an error. */
2085 gfc_match ("function% %n", name);
2086 if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2088 gfc_current_block ()->declared_at = gfc_current_locus;
2089 gfc_commit_symbols ();
2094 gfc_current_locus =loc;
2099 /* Parse a set of specification statements. Returns the statement
2100 that doesn't fit. */
2102 static gfc_statement
2103 parse_spec (gfc_statement st)
2106 bool bad_characteristic = false;
2109 verify_st_order (&ss, ST_NONE);
2111 st = next_statement ();
2121 case ST_DATA: /* Not allowed in interfaces */
2122 if (gfc_current_state () == COMP_INTERFACE)
2129 case ST_IMPLICIT_NONE:
2134 case ST_DERIVED_DECL:
2136 if (verify_st_order (&ss, st) == FAILURE)
2138 reject_statement ();
2139 st = next_statement ();
2149 case ST_DERIVED_DECL:
2155 if (gfc_current_state () != COMP_MODULE)
2157 gfc_error ("%s statement must appear in a MODULE",
2158 gfc_ascii_statement (st));
2162 if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2164 gfc_error ("%s statement at %C follows another accessibility "
2165 "specification", gfc_ascii_statement (st));
2169 gfc_current_ns->default_access = (st == ST_PUBLIC)
2170 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2174 case ST_STATEMENT_FUNCTION:
2175 if (gfc_current_state () == COMP_MODULE)
2177 unexpected_statement (st);
2185 accept_statement (st);
2186 st = next_statement ();
2190 accept_statement (st);
2192 st = next_statement ();
2195 case ST_GET_FCN_CHARACTERISTICS:
2196 /* This statement triggers the association of a function's result
2198 ts = &gfc_current_block ()->result->ts;
2199 if (match_deferred_characteristics (ts) != MATCH_YES)
2200 bad_characteristic = true;
2202 st = next_statement ();
2209 /* If match_deferred_characteristics failed, then there is an error. */
2210 if (bad_characteristic)
2212 ts = &gfc_current_block ()->result->ts;
2213 if (ts->type != BT_DERIVED)
2214 gfc_error ("Bad kind expression for function '%s' at %L",
2215 gfc_current_block ()->name,
2216 &gfc_current_block ()->declared_at);
2218 gfc_error ("The type for function '%s' at %L is not accessible",
2219 gfc_current_block ()->name,
2220 &gfc_current_block ()->declared_at);
2222 gfc_current_block ()->ts.kind = 0;
2223 /* Keep the derived type; if it's bad, it will be discovered later. */
2224 if (!(ts->type == BT_DERIVED && ts->derived))
2225 ts->type = BT_UNKNOWN;
2232 /* Parse a WHERE block, (not a simple WHERE statement). */
2235 parse_where_block (void)
2237 int seen_empty_else;
2242 accept_statement (ST_WHERE_BLOCK);
2243 top = gfc_state_stack->tail;
2245 push_state (&s, COMP_WHERE, gfc_new_block);
2247 d = add_statement ();
2248 d->expr = top->expr;
2254 seen_empty_else = 0;
2258 st = next_statement ();
2264 case ST_WHERE_BLOCK:
2265 parse_where_block ();
2270 accept_statement (st);
2274 if (seen_empty_else)
2276 gfc_error ("ELSEWHERE statement at %C follows previous "
2277 "unmasked ELSEWHERE");
2281 if (new_st.expr == NULL)
2282 seen_empty_else = 1;
2284 d = new_level (gfc_state_stack->head);
2286 d->expr = new_st.expr;
2288 accept_statement (st);
2293 accept_statement (st);
2297 gfc_error ("Unexpected %s statement in WHERE block at %C",
2298 gfc_ascii_statement (st));
2299 reject_statement ();
2303 while (st != ST_END_WHERE);
2309 /* Parse a FORALL block (not a simple FORALL statement). */
2312 parse_forall_block (void)
2318 accept_statement (ST_FORALL_BLOCK);
2319 top = gfc_state_stack->tail;
2321 push_state (&s, COMP_FORALL, gfc_new_block);
2323 d = add_statement ();
2324 d->op = EXEC_FORALL;
2329 st = next_statement ();
2334 case ST_POINTER_ASSIGNMENT:
2337 accept_statement (st);
2340 case ST_WHERE_BLOCK:
2341 parse_where_block ();
2344 case ST_FORALL_BLOCK:
2345 parse_forall_block ();
2349 accept_statement (st);
2356 gfc_error ("Unexpected %s statement in FORALL block at %C",
2357 gfc_ascii_statement (st));
2359 reject_statement ();
2363 while (st != ST_END_FORALL);
2369 static gfc_statement parse_executable (gfc_statement);
2371 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2374 parse_if_block (void)
2383 accept_statement (ST_IF_BLOCK);
2385 top = gfc_state_stack->tail;
2386 push_state (&s, COMP_IF, gfc_new_block);
2388 new_st.op = EXEC_IF;
2389 d = add_statement ();
2391 d->expr = top->expr;
2397 st = parse_executable (ST_NONE);
2407 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2408 "statement at %L", &else_locus);
2410 reject_statement ();
2414 d = new_level (gfc_state_stack->head);
2416 d->expr = new_st.expr;
2418 accept_statement (st);
2425 gfc_error ("Duplicate ELSE statements at %L and %C",
2427 reject_statement ();
2432 else_locus = gfc_current_locus;
2434 d = new_level (gfc_state_stack->head);
2437 accept_statement (st);
2445 unexpected_statement (st);
2449 while (st != ST_ENDIF);
2452 accept_statement (st);
2456 /* Parse a SELECT block. */
2459 parse_select_block (void)
2465 accept_statement (ST_SELECT_CASE);
2467 cp = gfc_state_stack->tail;
2468 push_state (&s, COMP_SELECT, gfc_new_block);
2470 /* Make sure that the next statement is a CASE or END SELECT. */
2473 st = next_statement ();
2476 if (st == ST_END_SELECT)
2478 /* Empty SELECT CASE is OK. */
2479 accept_statement (st);
2486 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2489 reject_statement ();
2492 /* At this point, we're got a nonempty select block. */
2493 cp = new_level (cp);
2496 accept_statement (st);
2500 st = parse_executable (ST_NONE);
2507 cp = new_level (gfc_state_stack->head);
2509 gfc_clear_new_st ();
2511 accept_statement (st);
2517 /* Can't have an executable statement because of
2518 parse_executable(). */
2520 unexpected_statement (st);
2524 while (st != ST_END_SELECT);
2527 accept_statement (st);
2531 /* Given a symbol, make sure it is not an iteration variable for a DO
2532 statement. This subroutine is called when the symbol is seen in a
2533 context that causes it to become redefined. If the symbol is an
2534 iterator, we generate an error message and return nonzero. */
2537 gfc_check_do_variable (gfc_symtree *st)
2541 for (s=gfc_state_stack; s; s = s->previous)
2542 if (s->do_variable == st)
2544 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2545 "loop beginning at %L", st->name, &s->head->loc);
2553 /* Checks to see if the current statement label closes an enddo.
2554 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2555 an error) if it incorrectly closes an ENDDO. */
2558 check_do_closure (void)
2562 if (gfc_statement_label == NULL)
2565 for (p = gfc_state_stack; p; p = p->previous)
2566 if (p->state == COMP_DO)
2570 return 0; /* No loops to close */
2572 if (p->ext.end_do_label == gfc_statement_label)
2575 if (p == gfc_state_stack)
2578 gfc_error ("End of nonblock DO statement at %C is within another block");
2582 /* At this point, the label doesn't terminate the innermost loop.
2583 Make sure it doesn't terminate another one. */
2584 for (; p; p = p->previous)
2585 if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2587 gfc_error ("End of nonblock DO statement at %C is interwoven "
2588 "with another DO loop");
2596 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2597 handled inside of parse_executable(), because they aren't really
2601 parse_do_block (void)
2608 s.ext.end_do_label = new_st.label;
2610 if (new_st.ext.iterator != NULL)
2611 stree = new_st.ext.iterator->var->symtree;
2615 accept_statement (ST_DO);
2617 top = gfc_state_stack->tail;
2618 push_state (&s, COMP_DO, gfc_new_block);
2620 s.do_variable = stree;
2622 top->block = new_level (top);
2623 top->block->op = EXEC_DO;
2626 st = parse_executable (ST_NONE);
2634 if (s.ext.end_do_label != NULL
2635 && s.ext.end_do_label != gfc_statement_label)
2636 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2639 if (gfc_statement_label != NULL)
2641 new_st.op = EXEC_NOP;
2646 case ST_IMPLIED_ENDDO:
2647 /* If the do-stmt of this DO construct has a do-construct-name,
2648 the corresponding end-do must be an end-do-stmt (with a matching
2649 name, but in that case we must have seen ST_ENDDO first).
2650 We only complain about this in pedantic mode. */
2651 if (gfc_current_block () != NULL)
2652 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2653 &gfc_current_block()->declared_at);
2658 unexpected_statement (st);
2663 accept_statement (st);
2667 /* Parse the statements of OpenMP do/parallel do. */
2669 static gfc_statement
2670 parse_omp_do (gfc_statement omp_st)
2676 accept_statement (omp_st);
2678 cp = gfc_state_stack->tail;
2679 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2680 np = new_level (cp);
2686 st = next_statement ();
2689 else if (st == ST_DO)
2692 unexpected_statement (st);
2696 if (gfc_statement_label != NULL
2697 && gfc_state_stack->previous != NULL
2698 && gfc_state_stack->previous->state == COMP_DO
2699 && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2707 there should be no !$OMP END DO. */
2709 return ST_IMPLIED_ENDDO;
2712 check_do_closure ();
2715 st = next_statement ();
2716 if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2718 if (new_st.op == EXEC_OMP_END_NOWAIT)
2719 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2721 gcc_assert (new_st.op == EXEC_NOP);
2722 gfc_clear_new_st ();
2723 gfc_commit_symbols ();
2724 gfc_warning_check ();
2725 st = next_statement ();
2731 /* Parse the statements of OpenMP atomic directive. */
2734 parse_omp_atomic (void)
2740 accept_statement (ST_OMP_ATOMIC);
2742 cp = gfc_state_stack->tail;
2743 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2744 np = new_level (cp);
2750 st = next_statement ();
2753 else if (st == ST_ASSIGNMENT)
2756 unexpected_statement (st);
2759 accept_statement (st);
2765 /* Parse the statements of an OpenMP structured block. */
2768 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2770 gfc_statement st, omp_end_st;
2774 accept_statement (omp_st);
2776 cp = gfc_state_stack->tail;
2777 push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2778 np = new_level (cp);
2784 case ST_OMP_PARALLEL:
2785 omp_end_st = ST_OMP_END_PARALLEL;
2787 case ST_OMP_PARALLEL_SECTIONS:
2788 omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2790 case ST_OMP_SECTIONS:
2791 omp_end_st = ST_OMP_END_SECTIONS;
2793 case ST_OMP_ORDERED:
2794 omp_end_st = ST_OMP_END_ORDERED;
2796 case ST_OMP_CRITICAL:
2797 omp_end_st = ST_OMP_END_CRITICAL;
2800 omp_end_st = ST_OMP_END_MASTER;
2803 omp_end_st = ST_OMP_END_SINGLE;
2805 case ST_OMP_WORKSHARE:
2806 omp_end_st = ST_OMP_END_WORKSHARE;
2808 case ST_OMP_PARALLEL_WORKSHARE:
2809 omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2817 if (workshare_stmts_only)
2819 /* Inside of !$omp workshare, only
2822 where statements and constructs
2823 forall statements and constructs
2827 are allowed. For !$omp critical these
2828 restrictions apply recursively. */
2831 st = next_statement ();
2842 accept_statement (st);
2845 case ST_WHERE_BLOCK:
2846 parse_where_block ();
2849 case ST_FORALL_BLOCK:
2850 parse_forall_block ();
2853 case ST_OMP_PARALLEL:
2854 case ST_OMP_PARALLEL_SECTIONS:
2855 parse_omp_structured_block (st, false);
2858 case ST_OMP_PARALLEL_WORKSHARE:
2859 case ST_OMP_CRITICAL:
2860 parse_omp_structured_block (st, true);
2863 case ST_OMP_PARALLEL_DO:
2864 st = parse_omp_do (st);
2868 parse_omp_atomic ();
2879 st = next_statement ();
2883 st = parse_executable (ST_NONE);
2886 else if (st == ST_OMP_SECTION
2887 && (omp_st == ST_OMP_SECTIONS
2888 || omp_st == ST_OMP_PARALLEL_SECTIONS))
2890 np = new_level (np);
2894 else if (st != omp_end_st)
2895 unexpected_statement (st);
2897 while (st != omp_end_st);
2901 case EXEC_OMP_END_NOWAIT:
2902 cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2904 case EXEC_OMP_CRITICAL:
2905 if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2906 || (new_st.ext.omp_name != NULL
2907 && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2908 gfc_error ("Name after !$omp critical and !$omp end critical does "
2910 gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2912 case EXEC_OMP_END_SINGLE:
2913 cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2914 = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2915 new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2916 gfc_free_omp_clauses (new_st.ext.omp_clauses);
2924 gfc_clear_new_st ();
2925 gfc_commit_symbols ();
2926 gfc_warning_check ();
2931 /* Accept a series of executable statements. We return the first
2932 statement that doesn't fit to the caller. Any block statements are
2933 passed on to the correct handler, which usually passes the buck
2936 static gfc_statement
2937 parse_executable (gfc_statement st)
2942 st = next_statement ();
2946 close_flag = check_do_closure ();
2951 case ST_END_PROGRAM:
2954 case ST_END_FUNCTION:
2958 case ST_END_SUBROUTINE:
2963 case ST_SELECT_CASE:
2964 gfc_error ("%s statement at %C cannot terminate a non-block "
2965 "DO loop", gfc_ascii_statement (st));
2981 accept_statement (st);
2982 if (close_flag == 1)
2983 return ST_IMPLIED_ENDDO;
2990 case ST_SELECT_CASE:
2991 parse_select_block ();
2996 if (check_do_closure () == 1)
2997 return ST_IMPLIED_ENDDO;
3000 case ST_WHERE_BLOCK:
3001 parse_where_block ();
3004 case ST_FORALL_BLOCK:
3005 parse_forall_block ();
3008 case ST_OMP_PARALLEL:
3009 case ST_OMP_PARALLEL_SECTIONS:
3010 case ST_OMP_SECTIONS:
3011 case ST_OMP_ORDERED:
3012 case ST_OMP_CRITICAL:
3015 parse_omp_structured_block (st, false);
3018 case ST_OMP_WORKSHARE:
3019 case ST_OMP_PARALLEL_WORKSHARE:
3020 parse_omp_structured_block (st, true);
3024 case ST_OMP_PARALLEL_DO:
3025 st = parse_omp_do (st);
3026 if (st == ST_IMPLIED_ENDDO)
3031 parse_omp_atomic ();
3038 st = next_statement ();
3043 /* Parse a series of contained program units. */
3045 static void parse_progunit (gfc_statement);
3048 /* Fix the symbols for sibling functions. These are incorrectly added to
3049 the child namespace as the parser didn't know about this procedure. */
3052 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3056 gfc_symbol *old_sym;
3058 sym->attr.referenced = 1;
3059 for (ns = siblings; ns; ns = ns->sibling)
3061 gfc_find_sym_tree (sym->name, ns, 0, &st);
3063 if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3066 old_sym = st->n.sym;
3067 if (old_sym->ns == ns
3068 && !old_sym->attr.contained
3070 /* By 14.6.1.3, host association should be excluded
3071 for the following. */
3072 && !(old_sym->attr.external
3073 || (old_sym->ts.type != BT_UNKNOWN
3074 && !old_sym->attr.implicit_type)
3075 || old_sym->attr.flavor == FL_PARAMETER
3076 || old_sym->attr.in_common
3077 || old_sym->attr.in_equivalence
3078 || old_sym->attr.data
3079 || old_sym->attr.dummy
3080 || old_sym->attr.result
3081 || old_sym->attr.dimension
3082 || old_sym->attr.allocatable
3083 || old_sym->attr.intrinsic
3084 || old_sym->attr.generic
3085 || old_sym->attr.flavor == FL_NAMELIST
3086 || old_sym->attr.proc == PROC_ST_FUNCTION))
3088 /* Replace it with the symbol from the parent namespace. */
3092 /* Free the old (local) symbol. */
3094 if (old_sym->refs == 0)
3095 gfc_free_symbol (old_sym);
3098 /* Do the same for any contained procedures. */
3099 gfc_fixup_sibling_symbols (sym, ns->contained);
3104 parse_contained (int module)
3106 gfc_namespace *ns, *parent_ns, *tmp;
3107 gfc_state_data s1, s2;
3111 int contains_statements = 0;
3114 push_state (&s1, COMP_CONTAINS, NULL);
3115 parent_ns = gfc_current_ns;
3119 gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3121 gfc_current_ns->sibling = parent_ns->contained;
3122 parent_ns->contained = gfc_current_ns;
3125 /* Process the next available statement. We come here if we got an error
3126 and rejected the last statement. */
3127 st = next_statement ();
3136 contains_statements = 1;
3137 accept_statement (st);
3140 (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3143 /* For internal procedures, create/update the symbol in the
3144 parent namespace. */
3148 if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3149 gfc_error ("Contained procedure '%s' at %C is already "
3150 "ambiguous", gfc_new_block->name);
3153 if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3154 &gfc_new_block->declared_at) ==
3157 if (st == ST_FUNCTION)
3158 gfc_add_function (&sym->attr, sym->name,
3159 &gfc_new_block->declared_at);
3161 gfc_add_subroutine (&sym->attr, sym->name,
3162 &gfc_new_block->declared_at);
3166 gfc_commit_symbols ();
3169 sym = gfc_new_block;
3171 /* Mark this as a contained function, so it isn't replaced
3172 by other module functions. */
3173 sym->attr.contained = 1;
3174 sym->attr.referenced = 1;
3176 parse_progunit (ST_NONE);
3178 /* Fix up any sibling functions that refer to this one. */
3179 gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3180 /* Or refer to any of its alternate entry points. */
3181 for (el = gfc_current_ns->entries; el; el = el->next)
3182 gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3184 gfc_current_ns->code = s2.head;
3185 gfc_current_ns = parent_ns;
3190 /* These statements are associated with the end of the host unit. */
3191 case ST_END_FUNCTION:
3193 case ST_END_PROGRAM:
3194 case ST_END_SUBROUTINE:
3195 accept_statement (st);
3199 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3200 gfc_ascii_statement (st));
3201 reject_statement ();
3207 while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3208 && st != ST_END_MODULE && st != ST_END_PROGRAM);
3210 /* The first namespace in the list is guaranteed to not have
3211 anything (worthwhile) in it. */
3212 tmp = gfc_current_ns;
3213 gfc_current_ns = parent_ns;
3214 if (seen_error && tmp->refs > 1)
3215 gfc_free_namespace (tmp);
3217 ns = gfc_current_ns->contained;
3218 gfc_current_ns->contained = ns->sibling;
3219 gfc_free_namespace (ns);
3222 if (!contains_statements)
3223 gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3224 "FUNCTION or SUBROUTINE statement at %C");
3228 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
3231 parse_progunit (gfc_statement st)
3236 st = parse_spec (st);
3246 accept_statement (st);
3253 if (gfc_current_state () == COMP_FUNCTION)
3254 gfc_check_function_type (gfc_current_ns);
3259 st = parse_executable (st);
3270 accept_statement (st);
3277 unexpected_statement (st);
3278 reject_statement ();
3279 st = next_statement ();
3285 for (p = gfc_state_stack; p; p = p->previous)
3286 if (p->state == COMP_CONTAINS)
3289 if (gfc_find_state (COMP_MODULE) == SUCCESS)
3294 gfc_error ("CONTAINS statement at %C is already in a contained "
3296 st = next_statement ();
3300 parse_contained (0);
3303 gfc_current_ns->code = gfc_state_stack->head;
3307 /* Come here to complain about a global symbol already in use as
3311 gfc_global_used (gfc_gsymbol *sym, locus *where)
3316 where = &gfc_current_locus;
3326 case GSYM_SUBROUTINE:
3327 name = "SUBROUTINE";
3332 case GSYM_BLOCK_DATA:
3333 name = "BLOCK DATA";
3339 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3343 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3344 sym->name, where, name, &sym->where);
3348 /* Parse a block data program unit. */
3351 parse_block_data (void)
3354 static locus blank_locus;
3355 static int blank_block=0;
3358 gfc_current_ns->proc_name = gfc_new_block;
3359 gfc_current_ns->is_block_data = 1;
3361 if (gfc_new_block == NULL)
3364 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3365 "prior BLOCK DATA at %L", &blank_locus);
3369 blank_locus = gfc_current_locus;
3374 s = gfc_get_gsymbol (gfc_new_block->name);
3376 || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3377 gfc_global_used(s, NULL);
3380 s->type = GSYM_BLOCK_DATA;
3381 s->where = gfc_current_locus;
3386 st = parse_spec (ST_NONE);
3388 while (st != ST_END_BLOCK_DATA)
3390 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3391 gfc_ascii_statement (st));
3392 reject_statement ();
3393 st = next_statement ();
3398 /* Parse a module subprogram. */
3406 s = gfc_get_gsymbol (gfc_new_block->name);
3407 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3408 gfc_global_used(s, NULL);
3411 s->type = GSYM_MODULE;
3412 s->where = gfc_current_locus;
3416 st = parse_spec (ST_NONE);
3425 parse_contained (1);
3429 accept_statement (st);
3433 gfc_error ("Unexpected %s statement in MODULE at %C",
3434 gfc_ascii_statement (st));
3436 reject_statement ();
3437 st = next_statement ();
3443 /* Add a procedure name to the global symbol table. */
3446 add_global_procedure (int sub)
3450 s = gfc_get_gsymbol(gfc_new_block->name);
3453 || (s->type != GSYM_UNKNOWN
3454 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3455 gfc_global_used(s, NULL);
3458 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3459 s->where = gfc_current_locus;
3465 /* Add a program to the global symbol table. */
3468 add_global_program (void)
3472 if (gfc_new_block == NULL)
3474 s = gfc_get_gsymbol (gfc_new_block->name);
3476 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3477 gfc_global_used(s, NULL);
3480 s->type = GSYM_PROGRAM;
3481 s->where = gfc_current_locus;
3487 /* Top level parser. */
3490 gfc_parse_file (void)
3492 int seen_program, errors_before, errors;
3493 gfc_state_data top, s;
3497 gfc_start_source_files ();
3499 top.state = COMP_NONE;
3501 top.previous = NULL;
3502 top.head = top.tail = NULL;
3503 top.do_variable = NULL;
3505 gfc_state_stack = ⊤
3507 gfc_clear_new_st ();
3509 gfc_statement_label = NULL;
3511 if (setjmp (eof_buf))
3512 return FAILURE; /* Come here on unexpected EOF */
3516 /* Exit early for empty files. */
3522 st = next_statement ();
3531 goto duplicate_main;
3533 prog_locus = gfc_current_locus;
3535 push_state (&s, COMP_PROGRAM, gfc_new_block);
3536 main_program_symbol(gfc_current_ns, gfc_new_block->name);
3537 accept_statement (st);
3538 add_global_program ();
3539 parse_progunit (ST_NONE);
3543 add_global_procedure (1);
3544 push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3545 accept_statement (st);
3546 parse_progunit (ST_NONE);
3550 add_global_procedure (0);
3551 push_state (&s, COMP_FUNCTION, gfc_new_block);
3552 accept_statement (st);
3553 parse_progunit (ST_NONE);
3557 push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3558 accept_statement (st);
3559 parse_block_data ();
3563 push_state (&s, COMP_MODULE, gfc_new_block);
3564 accept_statement (st);
3566 gfc_get_errors (NULL, &errors_before);
3570 /* Anything else starts a nameless main program block. */
3573 goto duplicate_main;
3575 prog_locus = gfc_current_locus;
3577 push_state (&s, COMP_PROGRAM, gfc_new_block);
3578 main_program_symbol (gfc_current_ns, "MAIN__");
3579 parse_progunit (st);
3583 gfc_current_ns->code = s.head;
3585 gfc_resolve (gfc_current_ns);
3587 /* Dump the parse tree if requested. */
3588 if (gfc_option.dump_parse_tree)
3589 gfc_dump_parse_tree (gfc_current_ns, stdout);
3591 gfc_get_errors (NULL, &errors);
3592 if (s.state == COMP_MODULE)
3594 gfc_dump_module (s.sym->name, errors_before == errors);
3596 gfc_generate_module_code (gfc_current_ns);
3601 gfc_generate_code (gfc_current_ns);
3609 gfc_end_source_files ();
3613 /* If we see a duplicate main program, shut down. If the second
3614 instance is an implied main program, ie data decls or executable
3615 statements, we're in for lots of errors. */
3616 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3617 reject_statement ();