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/>. */
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_numeric_ts (&gfc_current_block ()->ts
))
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_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_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 ("write", gfc_match_write
, ST_WRITE
);
447 /* All else has failed, so give up. See if any of the matchers has
448 stored an error message of some sort. */
450 if (gfc_error_check () == 0)
451 gfc_error_now ("Unclassifiable statement at %C");
455 gfc_error_recovery ();
461 decode_omp_directive (void)
470 gfc_clear_error (); /* Clear any pending errors. */
471 gfc_clear_warning (); /* Clear any pending warnings. */
475 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
476 "or ELEMENTAL procedures");
477 gfc_error_recovery ();
481 old_locus
= gfc_current_locus
;
483 /* General OpenMP directive matching: Instead of testing every possible
484 statement, we eliminate most possibilities by peeking at the
487 c
= gfc_peek_char ();
492 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
495 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
498 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
501 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
504 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
505 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
506 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
507 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
508 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
509 match ("end parallel sections", gfc_match_omp_eos
,
510 ST_OMP_END_PARALLEL_SECTIONS
);
511 match ("end parallel workshare", gfc_match_omp_eos
,
512 ST_OMP_END_PARALLEL_WORKSHARE
);
513 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
514 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
515 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
516 match ("end workshare", gfc_match_omp_end_nowait
,
517 ST_OMP_END_WORKSHARE
);
520 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
523 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
526 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
529 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
530 match ("parallel sections", gfc_match_omp_parallel_sections
,
531 ST_OMP_PARALLEL_SECTIONS
);
532 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
533 ST_OMP_PARALLEL_WORKSHARE
);
534 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
537 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
538 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
539 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
542 match ("threadprivate", gfc_match_omp_threadprivate
,
543 ST_OMP_THREADPRIVATE
);
545 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
549 /* All else has failed, so give up. See if any of the matchers has
550 stored an error message of some sort. */
552 if (gfc_error_check () == 0)
553 gfc_error_now ("Unclassifiable OpenMP directive at %C");
557 gfc_error_recovery ();
565 /* Get the next statement in free form source. */
571 int c
, d
, cnt
, at_bol
;
573 at_bol
= gfc_at_bol ();
574 gfc_gobble_whitespace ();
576 c
= gfc_peek_char ();
580 /* Found a statement label? */
581 m
= gfc_match_st_label (&gfc_statement_label
);
583 d
= gfc_peek_char ();
584 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
586 gfc_match_small_literal_int (&c
, &cnt
);
589 gfc_error_now ("Too many digits in statement label at %C");
592 gfc_error_now ("Zero is not a valid statement label at %C");
595 c
= gfc_next_char ();
598 if (!gfc_is_whitespace (c
))
599 gfc_error_now ("Non-numeric character in statement label at %C");
605 label_locus
= gfc_current_locus
;
607 gfc_gobble_whitespace ();
609 if (at_bol
&& gfc_peek_char () == ';')
611 gfc_error_now ("Semicolon at %C needs to be preceded by "
613 gfc_next_char (); /* Eat up the semicolon. */
617 if (gfc_match_eos () == MATCH_YES
)
619 gfc_warning_now ("Ignoring statement label in empty statement "
621 gfc_free_st_label (gfc_statement_label
);
622 gfc_statement_label
= NULL
;
629 /* Comments have already been skipped by the time we get here,
630 except for OpenMP directives. */
631 if (gfc_option
.flag_openmp
)
635 c
= gfc_next_char ();
636 for (i
= 0; i
< 5; i
++, c
= gfc_next_char ())
637 gcc_assert (c
== "!$omp"[i
]);
639 gcc_assert (c
== ' ');
640 gfc_gobble_whitespace ();
641 return decode_omp_directive ();
645 if (at_bol
&& c
== ';')
647 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
648 gfc_next_char (); /* Eat up the semicolon. */
652 return decode_statement ();
656 /* Get the next statement in fixed-form source. */
661 int label
, digit_flag
, i
;
666 return decode_statement ();
668 /* Skip past the current label field, parsing a statement label if
669 one is there. This is a weird number parser, since the number is
670 contained within five columns and can have any kind of embedded
671 spaces. We also check for characters that make the rest of the
677 for (i
= 0; i
< 5; i
++)
679 c
= gfc_next_char_literal (0);
696 label
= label
* 10 + c
- '0';
697 label_locus
= gfc_current_locus
;
701 /* Comments have already been skipped by the time we get
702 here, except for OpenMP directives. */
704 if (gfc_option
.flag_openmp
)
706 for (i
= 0; i
< 5; i
++, c
= gfc_next_char_literal (0))
707 gcc_assert (TOLOWER (c
) == "*$omp"[i
]);
709 if (c
!= ' ' && c
!= '0')
711 gfc_buffer_error (0);
712 gfc_error ("Bad continuation line at %C");
716 return decode_omp_directive ();
720 /* Comments have already been skipped by the time we get
721 here so don't bother checking for them. */
724 gfc_buffer_error (0);
725 gfc_error ("Non-numeric character in statement label at %C");
733 gfc_warning_now ("Zero is not a valid statement label at %C");
736 /* We've found a valid statement label. */
737 gfc_statement_label
= gfc_get_st_label (label
);
741 /* Since this line starts a statement, it cannot be a continuation
742 of a previous statement. If we see something here besides a
743 space or zero, it must be a bad continuation line. */
745 c
= gfc_next_char_literal (0);
749 if (c
!= ' ' && c
!= '0')
751 gfc_buffer_error (0);
752 gfc_error ("Bad continuation line at %C");
756 /* Now that we've taken care of the statement label columns, we have
757 to make sure that the first nonblank character is not a '!'. If
758 it is, the rest of the line is a comment. */
762 loc
= gfc_current_locus
;
763 c
= gfc_next_char_literal (0);
765 while (gfc_is_whitespace (c
));
769 gfc_current_locus
= loc
;
773 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
777 if (gfc_match_eos () == MATCH_YES
)
780 /* At this point, we've got a nonblank statement to parse. */
781 return decode_statement ();
785 gfc_warning ("Ignoring statement label in empty statement at %C");
791 /* Return the next non-ST_NONE statement to the caller. We also worry
792 about including files and the ends of include files at this stage. */
795 next_statement (void)
799 gfc_new_block
= NULL
;
803 gfc_statement_label
= NULL
;
804 gfc_buffer_error (1);
808 if ((gfc_option
.warn_line_truncation
|| gfc_current_form
== FORM_FREE
)
809 && gfc_current_locus
.lb
810 && gfc_current_locus
.lb
->truncated
)
811 gfc_warning_now ("Line truncated at %C");
816 gfc_skip_comments ();
824 if (gfc_define_undef_line ())
827 old_locus
= gfc_current_locus
;
829 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
835 gfc_buffer_error (0);
837 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
839 gfc_free_st_label (gfc_statement_label
);
840 gfc_statement_label
= NULL
;
841 gfc_current_locus
= old_locus
;
845 check_statement_label (st
);
851 /****************************** Parser ***********************************/
853 /* The parser subroutines are of type 'try' that fail if the file ends
856 /* Macros that expand to case-labels for various classes of
857 statements. Start with executable statements that directly do
860 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
861 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
862 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
863 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
864 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
865 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
866 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
867 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
870 /* Statements that mark other executable statements. */
872 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
873 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
874 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
875 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
876 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
877 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
879 /* Declaration statements */
881 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
882 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
883 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
886 /* Block end statements. Errors associated with interchanging these
887 are detected in gfc_match_end(). */
889 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
890 case ST_END_PROGRAM: case ST_END_SUBROUTINE
893 /* Push a new state onto the stack. */
896 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
898 p
->state
= new_state
;
899 p
->previous
= gfc_state_stack
;
901 p
->head
= p
->tail
= NULL
;
902 p
->do_variable
= NULL
;
907 /* Pop the current state. */
911 gfc_state_stack
= gfc_state_stack
->previous
;
915 /* Try to find the given state in the state stack. */
918 gfc_find_state (gfc_compile_state state
)
922 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
923 if (p
->state
== state
)
926 return (p
== NULL
) ? FAILURE
: SUCCESS
;
930 /* Starts a new level in the statement list. */
933 new_level (gfc_code
*q
)
937 p
= q
->block
= gfc_get_code ();
939 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
945 /* Add the current new_st code structure and adds it to the current
946 program unit. As a side-effect, it zeroes the new_st. */
956 p
->loc
= gfc_current_locus
;
958 if (gfc_state_stack
->head
== NULL
)
959 gfc_state_stack
->head
= p
;
961 gfc_state_stack
->tail
->next
= p
;
963 while (p
->next
!= NULL
)
966 gfc_state_stack
->tail
= p
;
974 /* Frees everything associated with the current statement. */
977 undo_new_statement (void)
979 gfc_free_statements (new_st
.block
);
980 gfc_free_statements (new_st
.next
);
981 gfc_free_statement (&new_st
);
986 /* If the current statement has a statement label, make sure that it
987 is allowed to, or should have one. */
990 check_statement_label (gfc_statement st
)
994 if (gfc_statement_label
== NULL
)
997 gfc_error ("FORMAT statement at %L does not have a statement label",
1004 case ST_END_PROGRAM
:
1005 case ST_END_FUNCTION
:
1006 case ST_END_SUBROUTINE
:
1012 type
= ST_LABEL_TARGET
;
1016 type
= ST_LABEL_FORMAT
;
1019 /* Statement labels are not restricted from appearing on a
1020 particular line. However, there are plenty of situations
1021 where the resulting label can't be referenced. */
1024 type
= ST_LABEL_BAD_TARGET
;
1028 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1030 new_st
.here
= gfc_statement_label
;
1034 /* Figures out what the enclosing program unit is. This will be a
1035 function, subroutine, program, block data or module. */
1038 gfc_enclosing_unit (gfc_compile_state
* result
)
1042 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1043 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1044 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1045 || p
->state
== COMP_PROGRAM
)
1054 *result
= COMP_PROGRAM
;
1059 /* Translate a statement enum to a string. */
1062 gfc_ascii_statement (gfc_statement st
)
1068 case ST_ARITHMETIC_IF
:
1069 p
= _("arithmetic IF");
1075 p
= _("attribute declaration");
1105 p
= _("data declaration");
1113 case ST_DERIVED_DECL
:
1114 p
= _("derived type declaration");
1128 case ST_END_BLOCK_DATA
:
1129 p
= "END BLOCK DATA";
1140 case ST_END_FUNCTION
:
1146 case ST_END_INTERFACE
:
1147 p
= "END INTERFACE";
1152 case ST_END_PROGRAM
:
1158 case ST_END_SUBROUTINE
:
1159 p
= "END SUBROUTINE";
1170 case ST_EQUIVALENCE
:
1179 case ST_FORALL_BLOCK
: /* Fall through */
1198 case ST_IMPLICIT_NONE
:
1199 p
= "IMPLICIT NONE";
1201 case ST_IMPLIED_ENDDO
:
1202 p
= _("implied END DO");
1228 case ST_MODULE_PROC
:
1229 p
= "MODULE PROCEDURE";
1267 case ST_WHERE_BLOCK
: /* Fall through */
1275 p
= _("assignment");
1277 case ST_POINTER_ASSIGNMENT
:
1278 p
= _("pointer assignment");
1280 case ST_SELECT_CASE
:
1289 case ST_STATEMENT_FUNCTION
:
1290 p
= "STATEMENT FUNCTION";
1292 case ST_LABEL_ASSIGNMENT
:
1293 p
= "LABEL ASSIGNMENT";
1296 p
= "ENUM DEFINITION";
1299 p
= "ENUMERATOR DEFINITION";
1307 case ST_OMP_BARRIER
:
1308 p
= "!$OMP BARRIER";
1310 case ST_OMP_CRITICAL
:
1311 p
= "!$OMP CRITICAL";
1316 case ST_OMP_END_CRITICAL
:
1317 p
= "!$OMP END CRITICAL";
1322 case ST_OMP_END_MASTER
:
1323 p
= "!$OMP END MASTER";
1325 case ST_OMP_END_ORDERED
:
1326 p
= "!$OMP END ORDERED";
1328 case ST_OMP_END_PARALLEL
:
1329 p
= "!$OMP END PARALLEL";
1331 case ST_OMP_END_PARALLEL_DO
:
1332 p
= "!$OMP END PARALLEL DO";
1334 case ST_OMP_END_PARALLEL_SECTIONS
:
1335 p
= "!$OMP END PARALLEL SECTIONS";
1337 case ST_OMP_END_PARALLEL_WORKSHARE
:
1338 p
= "!$OMP END PARALLEL WORKSHARE";
1340 case ST_OMP_END_SECTIONS
:
1341 p
= "!$OMP END SECTIONS";
1343 case ST_OMP_END_SINGLE
:
1344 p
= "!$OMP END SINGLE";
1346 case ST_OMP_END_WORKSHARE
:
1347 p
= "!$OMP END WORKSHARE";
1355 case ST_OMP_ORDERED
:
1356 p
= "!$OMP ORDERED";
1358 case ST_OMP_PARALLEL
:
1359 p
= "!$OMP PARALLEL";
1361 case ST_OMP_PARALLEL_DO
:
1362 p
= "!$OMP PARALLEL DO";
1364 case ST_OMP_PARALLEL_SECTIONS
:
1365 p
= "!$OMP PARALLEL SECTIONS";
1367 case ST_OMP_PARALLEL_WORKSHARE
:
1368 p
= "!$OMP PARALLEL WORKSHARE";
1370 case ST_OMP_SECTIONS
:
1371 p
= "!$OMP SECTIONS";
1373 case ST_OMP_SECTION
:
1374 p
= "!$OMP SECTION";
1379 case ST_OMP_THREADPRIVATE
:
1380 p
= "!$OMP THREADPRIVATE";
1382 case ST_OMP_WORKSHARE
:
1383 p
= "!$OMP WORKSHARE";
1386 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1393 /* Create a symbol for the main program and assign it to ns->proc_name. */
1396 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1398 gfc_symbol
*main_program
;
1399 symbol_attribute attr
;
1401 gfc_get_symbol (name
, ns
, &main_program
);
1402 gfc_clear_attr (&attr
);
1403 attr
.flavor
= FL_PROGRAM
;
1404 attr
.proc
= PROC_UNKNOWN
;
1405 attr
.subroutine
= 1;
1406 attr
.access
= ACCESS_PUBLIC
;
1407 attr
.is_main_program
= 1;
1408 main_program
->attr
= attr
;
1409 main_program
->declared_at
= gfc_current_locus
;
1410 ns
->proc_name
= main_program
;
1411 gfc_commit_symbols ();
1415 /* Do whatever is necessary to accept the last statement. */
1418 accept_statement (gfc_statement st
)
1426 case ST_IMPLICIT_NONE
:
1427 gfc_set_implicit_none ();
1436 gfc_current_ns
->proc_name
= gfc_new_block
;
1439 /* If the statement is the end of a block, lay down a special code
1440 that allows a branch to the end of the block from within the
1445 if (gfc_statement_label
!= NULL
)
1447 new_st
.op
= EXEC_NOP
;
1453 /* The end-of-program unit statements do not get the special
1454 marker and require a statement of some sort if they are a
1457 case ST_END_PROGRAM
:
1458 case ST_END_FUNCTION
:
1459 case ST_END_SUBROUTINE
:
1460 if (gfc_statement_label
!= NULL
)
1462 new_st
.op
= EXEC_RETURN
;
1478 gfc_commit_symbols ();
1479 gfc_warning_check ();
1480 gfc_clear_new_st ();
1484 /* Undo anything tentative that has been built for the current
1488 reject_statement (void)
1490 gfc_new_block
= NULL
;
1491 gfc_undo_symbols ();
1492 gfc_clear_warning ();
1493 undo_new_statement ();
1497 /* Generic complaint about an out of order statement. We also do
1498 whatever is necessary to clean up. */
1501 unexpected_statement (gfc_statement st
)
1503 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1505 reject_statement ();
1509 /* Given the next statement seen by the matcher, make sure that it is
1510 in proper order with the last. This subroutine is initialized by
1511 calling it with an argument of ST_NONE. If there is a problem, we
1512 issue an error and return FAILURE. Otherwise we return SUCCESS.
1514 Individual parsers need to verify that the statements seen are
1515 valid before calling here, ie ENTRY statements are not allowed in
1516 INTERFACE blocks. The following diagram is taken from the standard:
1518 +---------------------------------------+
1519 | program subroutine function module |
1520 +---------------------------------------+
1522 +---------------------------------------+
1524 +---------------------------------------+
1526 | +-----------+------------------+
1527 | | parameter | implicit |
1528 | +-----------+------------------+
1529 | format | | derived type |
1530 | entry | parameter | interface |
1531 | | data | specification |
1532 | | | statement func |
1533 | +-----------+------------------+
1534 | | data | executable |
1535 +--------+-----------+------------------+
1537 +---------------------------------------+
1538 | internal module/subprogram |
1539 +---------------------------------------+
1541 +---------------------------------------+
1548 { ORDER_START
, ORDER_USE
, ORDER_IMPORT
, ORDER_IMPLICIT_NONE
,
1549 ORDER_IMPLICIT
, ORDER_SPEC
, ORDER_EXEC
1552 gfc_statement last_statement
;
1558 verify_st_order (st_state
*p
, gfc_statement st
)
1564 p
->state
= ORDER_START
;
1568 if (p
->state
> ORDER_USE
)
1570 p
->state
= ORDER_USE
;
1574 if (p
->state
> ORDER_IMPORT
)
1576 p
->state
= ORDER_IMPORT
;
1579 case ST_IMPLICIT_NONE
:
1580 if (p
->state
> ORDER_IMPLICIT_NONE
)
1583 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1584 statement disqualifies a USE but not an IMPLICIT NONE.
1585 Duplicate IMPLICIT NONEs are caught when the implicit types
1588 p
->state
= ORDER_IMPLICIT_NONE
;
1592 if (p
->state
> ORDER_IMPLICIT
)
1594 p
->state
= ORDER_IMPLICIT
;
1599 if (p
->state
< ORDER_IMPLICIT_NONE
)
1600 p
->state
= ORDER_IMPLICIT_NONE
;
1604 if (p
->state
>= ORDER_EXEC
)
1606 if (p
->state
< ORDER_IMPLICIT
)
1607 p
->state
= ORDER_IMPLICIT
;
1611 if (p
->state
< ORDER_SPEC
)
1612 p
->state
= ORDER_SPEC
;
1617 case ST_DERIVED_DECL
:
1619 if (p
->state
>= ORDER_EXEC
)
1621 if (p
->state
< ORDER_SPEC
)
1622 p
->state
= ORDER_SPEC
;
1627 if (p
->state
< ORDER_EXEC
)
1628 p
->state
= ORDER_EXEC
;
1632 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1633 gfc_ascii_statement (st
));
1636 /* All is well, record the statement in case we need it next time. */
1637 p
->where
= gfc_current_locus
;
1638 p
->last_statement
= st
;
1642 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1643 gfc_ascii_statement (st
),
1644 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1650 /* Handle an unexpected end of file. This is a show-stopper... */
1652 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1655 unexpected_eof (void)
1659 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1661 /* Memory cleanup. Move to "second to last". */
1662 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1665 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1668 longjmp (eof_buf
, 1);
1672 /* Parse a derived type. */
1675 parse_derived (void)
1677 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1680 gfc_symbol
*derived_sym
= NULL
;
1686 accept_statement (ST_DERIVED_DECL
);
1687 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1689 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1696 while (compiling_type
)
1698 st
= next_statement ();
1706 accept_statement (st
);
1714 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
1715 "definition at %C without components")
1719 accept_statement (ST_END_TYPE
);
1723 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1725 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1733 gfc_error ("PRIVATE statement at %C must precede "
1734 "structure components");
1741 gfc_error ("Duplicate PRIVATE statement at %C");
1745 s
.sym
->component_access
= ACCESS_PRIVATE
;
1746 accept_statement (ST_PRIVATE
);
1753 gfc_error ("SEQUENCE statement at %C must precede "
1754 "structure components");
1759 if (gfc_current_block ()->attr
.sequence
)
1760 gfc_warning ("SEQUENCE attribute at %C already specified in "
1765 gfc_error ("Duplicate SEQUENCE statement at %C");
1770 gfc_add_sequence (&gfc_current_block ()->attr
,
1771 gfc_current_block ()->name
, NULL
);
1775 unexpected_statement (st
);
1780 /* need to verify that all fields of the derived type are
1781 * interoperable with C if the type is declared to be bind(c)
1783 derived_sym
= gfc_current_block();
1785 sym
= gfc_current_block ();
1786 for (c
= sym
->components
; c
; c
= c
->next
)
1788 /* Look for allocatable components. */
1790 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.alloc_comp
))
1792 sym
->attr
.alloc_comp
= 1;
1796 /* Look for pointer components. */
1798 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.pointer_comp
))
1800 sym
->attr
.pointer_comp
= 1;
1804 /* Look for private components. */
1805 if (sym
->component_access
== ACCESS_PRIVATE
1806 || c
->access
== ACCESS_PRIVATE
1807 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.private_comp
))
1809 sym
->attr
.private_comp
= 1;
1814 if (!seen_component
)
1815 sym
->attr
.zero_comp
= 1;
1821 /* Parse an ENUM. */
1830 int seen_enumerator
= 0;
1834 push_state (&s
, COMP_ENUM
, gfc_new_block
);
1838 while (compiling_enum
)
1840 st
= next_statement ();
1848 seen_enumerator
= 1;
1849 accept_statement (st
);
1854 if (!seen_enumerator
)
1856 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1859 accept_statement (st
);
1863 gfc_free_enum_history ();
1864 unexpected_statement (st
);
1872 /* Parse an interface. We must be able to deal with the possibility
1873 of recursive interfaces. The parse_spec() subroutine is mutually
1874 recursive with parse_interface(). */
1876 static gfc_statement
parse_spec (gfc_statement
);
1879 parse_interface (void)
1881 gfc_compile_state new_state
, current_state
;
1882 gfc_symbol
*prog_unit
, *sym
;
1883 gfc_interface_info save
;
1884 gfc_state_data s1
, s2
;
1888 accept_statement (ST_INTERFACE
);
1890 current_interface
.ns
= gfc_current_ns
;
1891 save
= current_interface
;
1893 sym
= (current_interface
.type
== INTERFACE_GENERIC
1894 || current_interface
.type
== INTERFACE_USER_OP
)
1895 ? gfc_new_block
: NULL
;
1897 push_state (&s1
, COMP_INTERFACE
, sym
);
1898 current_state
= COMP_NONE
;
1901 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1903 st
= next_statement ();
1910 new_state
= COMP_SUBROUTINE
;
1911 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1912 gfc_new_block
->formal
, NULL
);
1916 new_state
= COMP_FUNCTION
;
1917 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1918 gfc_new_block
->formal
, NULL
);
1922 case ST_MODULE_PROC
: /* The module procedure matcher makes
1923 sure the context is correct. */
1924 accept_statement (st
);
1925 gfc_free_namespace (gfc_current_ns
);
1928 case ST_END_INTERFACE
:
1929 gfc_free_namespace (gfc_current_ns
);
1930 gfc_current_ns
= current_interface
.ns
;
1934 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1935 gfc_ascii_statement (st
));
1936 reject_statement ();
1937 gfc_free_namespace (gfc_current_ns
);
1942 /* Make sure that a generic interface has only subroutines or
1943 functions and that the generic name has the right attribute. */
1944 if (current_interface
.type
== INTERFACE_GENERIC
)
1946 if (current_state
== COMP_NONE
)
1948 if (new_state
== COMP_FUNCTION
)
1949 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1950 else if (new_state
== COMP_SUBROUTINE
)
1951 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1953 current_state
= new_state
;
1957 if (new_state
!= current_state
)
1959 if (new_state
== COMP_SUBROUTINE
)
1960 gfc_error ("SUBROUTINE at %C does not belong in a "
1961 "generic function interface");
1963 if (new_state
== COMP_FUNCTION
)
1964 gfc_error ("FUNCTION at %C does not belong in a "
1965 "generic subroutine interface");
1970 if (current_interface
.type
== INTERFACE_ABSTRACT
)
1972 gfc_new_block
->attr
.abstract
= 1;
1973 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
1974 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1975 "cannot be the same as an intrinsic type",
1976 gfc_new_block
->name
);
1979 push_state (&s2
, new_state
, gfc_new_block
);
1980 accept_statement (st
);
1981 prog_unit
= gfc_new_block
;
1982 prog_unit
->formal_ns
= gfc_current_ns
;
1983 proc_locus
= gfc_current_locus
;
1986 /* Read data declaration statements. */
1987 st
= parse_spec (ST_NONE
);
1989 /* Since the interface block does not permit an IMPLICIT statement,
1990 the default type for the function or the result must be taken
1991 from the formal namespace. */
1992 if (new_state
== COMP_FUNCTION
)
1994 if (prog_unit
->result
== prog_unit
1995 && prog_unit
->ts
.type
== BT_UNKNOWN
)
1996 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
1997 else if (prog_unit
->result
!= prog_unit
1998 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
1999 gfc_set_default_type (prog_unit
->result
, 1,
2000 prog_unit
->formal_ns
);
2003 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
2005 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2006 gfc_ascii_statement (st
));
2007 reject_statement ();
2011 current_interface
= save
;
2012 gfc_add_interface (prog_unit
);
2015 if (current_interface
.ns
2016 && current_interface
.ns
->proc_name
2017 && strcmp (current_interface
.ns
->proc_name
->name
,
2018 prog_unit
->name
) == 0)
2019 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2020 "enclosing procedure", prog_unit
->name
, &proc_locus
);
2029 /* Associate function characteristics by going back to the function
2030 declaration and rematching the prefix. */
2033 match_deferred_characteristics (gfc_typespec
* ts
)
2036 match m
= MATCH_ERROR
;
2037 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2039 loc
= gfc_current_locus
;
2041 gfc_current_locus
= gfc_current_block ()->declared_at
;
2044 gfc_buffer_error (1);
2045 m
= gfc_match_prefix (ts
);
2046 gfc_buffer_error (0);
2048 if (ts
->type
== BT_DERIVED
)
2052 if (!ts
->derived
|| !ts
->derived
->components
)
2056 /* Only permit one go at the characteristic association. */
2060 /* Set the function locus correctly. If we have not found the
2061 function name, there is an error. */
2062 gfc_match ("function% %n", name
);
2063 if (m
== MATCH_YES
&& strcmp (name
, gfc_current_block ()->name
) == 0)
2065 gfc_current_block ()->declared_at
= gfc_current_locus
;
2066 gfc_commit_symbols ();
2071 gfc_current_locus
=loc
;
2076 /* Parse a set of specification statements. Returns the statement
2077 that doesn't fit. */
2079 static gfc_statement
2080 parse_spec (gfc_statement st
)
2083 bool bad_characteristic
= false;
2086 verify_st_order (&ss
, ST_NONE
);
2088 st
= next_statement ();
2098 case ST_DATA
: /* Not allowed in interfaces */
2099 if (gfc_current_state () == COMP_INTERFACE
)
2106 case ST_IMPLICIT_NONE
:
2111 case ST_DERIVED_DECL
:
2113 if (verify_st_order (&ss
, st
) == FAILURE
)
2115 reject_statement ();
2116 st
= next_statement ();
2126 case ST_DERIVED_DECL
:
2132 if (gfc_current_state () != COMP_MODULE
)
2134 gfc_error ("%s statement must appear in a MODULE",
2135 gfc_ascii_statement (st
));
2139 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
2141 gfc_error ("%s statement at %C follows another accessibility "
2142 "specification", gfc_ascii_statement (st
));
2146 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
2147 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2151 case ST_STATEMENT_FUNCTION
:
2152 if (gfc_current_state () == COMP_MODULE
)
2154 unexpected_statement (st
);
2162 accept_statement (st
);
2163 st
= next_statement ();
2167 accept_statement (st
);
2169 st
= next_statement ();
2172 case ST_GET_FCN_CHARACTERISTICS
:
2173 /* This statement triggers the association of a function's result
2175 ts
= &gfc_current_block ()->result
->ts
;
2176 if (match_deferred_characteristics (ts
) != MATCH_YES
)
2177 bad_characteristic
= true;
2179 st
= next_statement ();
2186 /* If match_deferred_characteristics failed, then there is an error. */
2187 if (bad_characteristic
)
2189 ts
= &gfc_current_block ()->result
->ts
;
2190 if (ts
->type
!= BT_DERIVED
)
2191 gfc_error ("Bad kind expression for function '%s' at %L",
2192 gfc_current_block ()->name
,
2193 &gfc_current_block ()->declared_at
);
2195 gfc_error ("The type for function '%s' at %L is not accessible",
2196 gfc_current_block ()->name
,
2197 &gfc_current_block ()->declared_at
);
2199 gfc_current_block ()->ts
.kind
= 0;
2200 /* Keep the derived type; if it's bad, it will be discovered later. */
2201 if (!(ts
->type
== BT_DERIVED
&& ts
->derived
))
2202 ts
->type
= BT_UNKNOWN
;
2209 /* Parse a WHERE block, (not a simple WHERE statement). */
2212 parse_where_block (void)
2214 int seen_empty_else
;
2219 accept_statement (ST_WHERE_BLOCK
);
2220 top
= gfc_state_stack
->tail
;
2222 push_state (&s
, COMP_WHERE
, gfc_new_block
);
2224 d
= add_statement ();
2225 d
->expr
= top
->expr
;
2231 seen_empty_else
= 0;
2235 st
= next_statement ();
2241 case ST_WHERE_BLOCK
:
2242 parse_where_block ();
2247 accept_statement (st
);
2251 if (seen_empty_else
)
2253 gfc_error ("ELSEWHERE statement at %C follows previous "
2254 "unmasked ELSEWHERE");
2258 if (new_st
.expr
== NULL
)
2259 seen_empty_else
= 1;
2261 d
= new_level (gfc_state_stack
->head
);
2263 d
->expr
= new_st
.expr
;
2265 accept_statement (st
);
2270 accept_statement (st
);
2274 gfc_error ("Unexpected %s statement in WHERE block at %C",
2275 gfc_ascii_statement (st
));
2276 reject_statement ();
2280 while (st
!= ST_END_WHERE
);
2286 /* Parse a FORALL block (not a simple FORALL statement). */
2289 parse_forall_block (void)
2295 accept_statement (ST_FORALL_BLOCK
);
2296 top
= gfc_state_stack
->tail
;
2298 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2300 d
= add_statement ();
2301 d
->op
= EXEC_FORALL
;
2306 st
= next_statement ();
2311 case ST_POINTER_ASSIGNMENT
:
2314 accept_statement (st
);
2317 case ST_WHERE_BLOCK
:
2318 parse_where_block ();
2321 case ST_FORALL_BLOCK
:
2322 parse_forall_block ();
2326 accept_statement (st
);
2333 gfc_error ("Unexpected %s statement in FORALL block at %C",
2334 gfc_ascii_statement (st
));
2336 reject_statement ();
2340 while (st
!= ST_END_FORALL
);
2346 static gfc_statement
parse_executable (gfc_statement
);
2348 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2351 parse_if_block (void)
2360 accept_statement (ST_IF_BLOCK
);
2362 top
= gfc_state_stack
->tail
;
2363 push_state (&s
, COMP_IF
, gfc_new_block
);
2365 new_st
.op
= EXEC_IF
;
2366 d
= add_statement ();
2368 d
->expr
= top
->expr
;
2374 st
= parse_executable (ST_NONE
);
2384 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2385 "statement at %L", &else_locus
);
2387 reject_statement ();
2391 d
= new_level (gfc_state_stack
->head
);
2393 d
->expr
= new_st
.expr
;
2395 accept_statement (st
);
2402 gfc_error ("Duplicate ELSE statements at %L and %C",
2404 reject_statement ();
2409 else_locus
= gfc_current_locus
;
2411 d
= new_level (gfc_state_stack
->head
);
2414 accept_statement (st
);
2422 unexpected_statement (st
);
2426 while (st
!= ST_ENDIF
);
2429 accept_statement (st
);
2433 /* Parse a SELECT block. */
2436 parse_select_block (void)
2442 accept_statement (ST_SELECT_CASE
);
2444 cp
= gfc_state_stack
->tail
;
2445 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2447 /* Make sure that the next statement is a CASE or END SELECT. */
2450 st
= next_statement ();
2453 if (st
== ST_END_SELECT
)
2455 /* Empty SELECT CASE is OK. */
2456 accept_statement (st
);
2463 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2466 reject_statement ();
2469 /* At this point, we're got a nonempty select block. */
2470 cp
= new_level (cp
);
2473 accept_statement (st
);
2477 st
= parse_executable (ST_NONE
);
2484 cp
= new_level (gfc_state_stack
->head
);
2486 gfc_clear_new_st ();
2488 accept_statement (st
);
2494 /* Can't have an executable statement because of
2495 parse_executable(). */
2497 unexpected_statement (st
);
2501 while (st
!= ST_END_SELECT
);
2504 accept_statement (st
);
2508 /* Given a symbol, make sure it is not an iteration variable for a DO
2509 statement. This subroutine is called when the symbol is seen in a
2510 context that causes it to become redefined. If the symbol is an
2511 iterator, we generate an error message and return nonzero. */
2514 gfc_check_do_variable (gfc_symtree
*st
)
2518 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2519 if (s
->do_variable
== st
)
2521 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2522 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2530 /* Checks to see if the current statement label closes an enddo.
2531 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2532 an error) if it incorrectly closes an ENDDO. */
2535 check_do_closure (void)
2539 if (gfc_statement_label
== NULL
)
2542 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2543 if (p
->state
== COMP_DO
)
2547 return 0; /* No loops to close */
2549 if (p
->ext
.end_do_label
== gfc_statement_label
)
2552 if (p
== gfc_state_stack
)
2555 gfc_error ("End of nonblock DO statement at %C is within another block");
2559 /* At this point, the label doesn't terminate the innermost loop.
2560 Make sure it doesn't terminate another one. */
2561 for (; p
; p
= p
->previous
)
2562 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
2564 gfc_error ("End of nonblock DO statement at %C is interwoven "
2565 "with another DO loop");
2573 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2574 handled inside of parse_executable(), because they aren't really
2578 parse_do_block (void)
2585 s
.ext
.end_do_label
= new_st
.label
;
2587 if (new_st
.ext
.iterator
!= NULL
)
2588 stree
= new_st
.ext
.iterator
->var
->symtree
;
2592 accept_statement (ST_DO
);
2594 top
= gfc_state_stack
->tail
;
2595 push_state (&s
, COMP_DO
, gfc_new_block
);
2597 s
.do_variable
= stree
;
2599 top
->block
= new_level (top
);
2600 top
->block
->op
= EXEC_DO
;
2603 st
= parse_executable (ST_NONE
);
2611 if (s
.ext
.end_do_label
!= NULL
2612 && s
.ext
.end_do_label
!= gfc_statement_label
)
2613 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2616 if (gfc_statement_label
!= NULL
)
2618 new_st
.op
= EXEC_NOP
;
2623 case ST_IMPLIED_ENDDO
:
2624 /* If the do-stmt of this DO construct has a do-construct-name,
2625 the corresponding end-do must be an end-do-stmt (with a matching
2626 name, but in that case we must have seen ST_ENDDO first).
2627 We only complain about this in pedantic mode. */
2628 if (gfc_current_block () != NULL
)
2629 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2630 &gfc_current_block()->declared_at
);
2635 unexpected_statement (st
);
2640 accept_statement (st
);
2644 /* Parse the statements of OpenMP do/parallel do. */
2646 static gfc_statement
2647 parse_omp_do (gfc_statement omp_st
)
2653 accept_statement (omp_st
);
2655 cp
= gfc_state_stack
->tail
;
2656 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2657 np
= new_level (cp
);
2663 st
= next_statement ();
2666 else if (st
== ST_DO
)
2669 unexpected_statement (st
);
2673 if (gfc_statement_label
!= NULL
2674 && gfc_state_stack
->previous
!= NULL
2675 && gfc_state_stack
->previous
->state
== COMP_DO
2676 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
2684 there should be no !$OMP END DO. */
2686 return ST_IMPLIED_ENDDO
;
2689 check_do_closure ();
2692 st
= next_statement ();
2693 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
2695 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
2696 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2698 gcc_assert (new_st
.op
== EXEC_NOP
);
2699 gfc_clear_new_st ();
2700 gfc_commit_symbols ();
2701 gfc_warning_check ();
2702 st
= next_statement ();
2708 /* Parse the statements of OpenMP atomic directive. */
2711 parse_omp_atomic (void)
2717 accept_statement (ST_OMP_ATOMIC
);
2719 cp
= gfc_state_stack
->tail
;
2720 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2721 np
= new_level (cp
);
2727 st
= next_statement ();
2730 else if (st
== ST_ASSIGNMENT
)
2733 unexpected_statement (st
);
2736 accept_statement (st
);
2742 /* Parse the statements of an OpenMP structured block. */
2745 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
2747 gfc_statement st
, omp_end_st
;
2751 accept_statement (omp_st
);
2753 cp
= gfc_state_stack
->tail
;
2754 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2755 np
= new_level (cp
);
2761 case ST_OMP_PARALLEL
:
2762 omp_end_st
= ST_OMP_END_PARALLEL
;
2764 case ST_OMP_PARALLEL_SECTIONS
:
2765 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
2767 case ST_OMP_SECTIONS
:
2768 omp_end_st
= ST_OMP_END_SECTIONS
;
2770 case ST_OMP_ORDERED
:
2771 omp_end_st
= ST_OMP_END_ORDERED
;
2773 case ST_OMP_CRITICAL
:
2774 omp_end_st
= ST_OMP_END_CRITICAL
;
2777 omp_end_st
= ST_OMP_END_MASTER
;
2780 omp_end_st
= ST_OMP_END_SINGLE
;
2782 case ST_OMP_WORKSHARE
:
2783 omp_end_st
= ST_OMP_END_WORKSHARE
;
2785 case ST_OMP_PARALLEL_WORKSHARE
:
2786 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
2794 if (workshare_stmts_only
)
2796 /* Inside of !$omp workshare, only
2799 where statements and constructs
2800 forall statements and constructs
2804 are allowed. For !$omp critical these
2805 restrictions apply recursively. */
2808 st
= next_statement ();
2819 accept_statement (st
);
2822 case ST_WHERE_BLOCK
:
2823 parse_where_block ();
2826 case ST_FORALL_BLOCK
:
2827 parse_forall_block ();
2830 case ST_OMP_PARALLEL
:
2831 case ST_OMP_PARALLEL_SECTIONS
:
2832 parse_omp_structured_block (st
, false);
2835 case ST_OMP_PARALLEL_WORKSHARE
:
2836 case ST_OMP_CRITICAL
:
2837 parse_omp_structured_block (st
, true);
2840 case ST_OMP_PARALLEL_DO
:
2841 st
= parse_omp_do (st
);
2845 parse_omp_atomic ();
2856 st
= next_statement ();
2860 st
= parse_executable (ST_NONE
);
2863 else if (st
== ST_OMP_SECTION
2864 && (omp_st
== ST_OMP_SECTIONS
2865 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
2867 np
= new_level (np
);
2871 else if (st
!= omp_end_st
)
2872 unexpected_statement (st
);
2874 while (st
!= omp_end_st
);
2878 case EXEC_OMP_END_NOWAIT
:
2879 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2881 case EXEC_OMP_CRITICAL
:
2882 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
2883 || (new_st
.ext
.omp_name
!= NULL
2884 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
2885 gfc_error ("Name after !$omp critical and !$omp end critical does "
2887 gfc_free (CONST_CAST (char *, new_st
.ext
.omp_name
));
2889 case EXEC_OMP_END_SINGLE
:
2890 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
2891 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
2892 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
2893 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
2901 gfc_clear_new_st ();
2902 gfc_commit_symbols ();
2903 gfc_warning_check ();
2908 /* Accept a series of executable statements. We return the first
2909 statement that doesn't fit to the caller. Any block statements are
2910 passed on to the correct handler, which usually passes the buck
2913 static gfc_statement
2914 parse_executable (gfc_statement st
)
2919 st
= next_statement ();
2923 close_flag
= check_do_closure ();
2928 case ST_END_PROGRAM
:
2931 case ST_END_FUNCTION
:
2935 case ST_END_SUBROUTINE
:
2940 case ST_SELECT_CASE
:
2941 gfc_error ("%s statement at %C cannot terminate a non-block "
2942 "DO loop", gfc_ascii_statement (st
));
2958 accept_statement (st
);
2959 if (close_flag
== 1)
2960 return ST_IMPLIED_ENDDO
;
2967 case ST_SELECT_CASE
:
2968 parse_select_block ();
2973 if (check_do_closure () == 1)
2974 return ST_IMPLIED_ENDDO
;
2977 case ST_WHERE_BLOCK
:
2978 parse_where_block ();
2981 case ST_FORALL_BLOCK
:
2982 parse_forall_block ();
2985 case ST_OMP_PARALLEL
:
2986 case ST_OMP_PARALLEL_SECTIONS
:
2987 case ST_OMP_SECTIONS
:
2988 case ST_OMP_ORDERED
:
2989 case ST_OMP_CRITICAL
:
2992 parse_omp_structured_block (st
, false);
2995 case ST_OMP_WORKSHARE
:
2996 case ST_OMP_PARALLEL_WORKSHARE
:
2997 parse_omp_structured_block (st
, true);
3001 case ST_OMP_PARALLEL_DO
:
3002 st
= parse_omp_do (st
);
3003 if (st
== ST_IMPLIED_ENDDO
)
3008 parse_omp_atomic ();
3015 st
= next_statement ();
3020 /* Parse a series of contained program units. */
3022 static void parse_progunit (gfc_statement
);
3025 /* Fix the symbols for sibling functions. These are incorrectly added to
3026 the child namespace as the parser didn't know about this procedure. */
3029 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
3033 gfc_symbol
*old_sym
;
3035 sym
->attr
.referenced
= 1;
3036 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
3038 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
3040 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
3043 old_sym
= st
->n
.sym
;
3044 if (old_sym
->ns
== ns
3045 && !old_sym
->attr
.contained
3047 /* By 14.6.1.3, host association should be excluded
3048 for the following. */
3049 && !(old_sym
->attr
.external
3050 || (old_sym
->ts
.type
!= BT_UNKNOWN
3051 && !old_sym
->attr
.implicit_type
)
3052 || old_sym
->attr
.flavor
== FL_PARAMETER
3053 || old_sym
->attr
.in_common
3054 || old_sym
->attr
.in_equivalence
3055 || old_sym
->attr
.data
3056 || old_sym
->attr
.dummy
3057 || old_sym
->attr
.result
3058 || old_sym
->attr
.dimension
3059 || old_sym
->attr
.allocatable
3060 || old_sym
->attr
.intrinsic
3061 || old_sym
->attr
.generic
3062 || old_sym
->attr
.flavor
== FL_NAMELIST
3063 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
3065 /* Replace it with the symbol from the parent namespace. */
3069 /* Free the old (local) symbol. */
3071 if (old_sym
->refs
== 0)
3072 gfc_free_symbol (old_sym
);
3075 /* Do the same for any contained procedures. */
3076 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
3081 parse_contained (int module
)
3083 gfc_namespace
*ns
, *parent_ns
, *tmp
;
3084 gfc_state_data s1
, s2
;
3088 int contains_statements
= 0;
3091 push_state (&s1
, COMP_CONTAINS
, NULL
);
3092 parent_ns
= gfc_current_ns
;
3096 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
3098 gfc_current_ns
->sibling
= parent_ns
->contained
;
3099 parent_ns
->contained
= gfc_current_ns
;
3102 /* Process the next available statement. We come here if we got an error
3103 and rejected the last statement. */
3104 st
= next_statement ();
3113 contains_statements
= 1;
3114 accept_statement (st
);
3117 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
3120 /* For internal procedures, create/update the symbol in the
3121 parent namespace. */
3125 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
3126 gfc_error ("Contained procedure '%s' at %C is already "
3127 "ambiguous", gfc_new_block
->name
);
3130 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
3131 &gfc_new_block
->declared_at
) ==
3134 if (st
== ST_FUNCTION
)
3135 gfc_add_function (&sym
->attr
, sym
->name
,
3136 &gfc_new_block
->declared_at
);
3138 gfc_add_subroutine (&sym
->attr
, sym
->name
,
3139 &gfc_new_block
->declared_at
);
3143 gfc_commit_symbols ();
3146 sym
= gfc_new_block
;
3148 /* Mark this as a contained function, so it isn't replaced
3149 by other module functions. */
3150 sym
->attr
.contained
= 1;
3151 sym
->attr
.referenced
= 1;
3153 parse_progunit (ST_NONE
);
3155 /* Fix up any sibling functions that refer to this one. */
3156 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
3157 /* Or refer to any of its alternate entry points. */
3158 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
3159 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
3161 gfc_current_ns
->code
= s2
.head
;
3162 gfc_current_ns
= parent_ns
;
3167 /* These statements are associated with the end of the host unit. */
3168 case ST_END_FUNCTION
:
3170 case ST_END_PROGRAM
:
3171 case ST_END_SUBROUTINE
:
3172 accept_statement (st
);
3176 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3177 gfc_ascii_statement (st
));
3178 reject_statement ();
3184 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
3185 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
3187 /* The first namespace in the list is guaranteed to not have
3188 anything (worthwhile) in it. */
3189 tmp
= gfc_current_ns
;
3190 gfc_current_ns
= parent_ns
;
3191 if (seen_error
&& tmp
->refs
> 1)
3192 gfc_free_namespace (tmp
);
3194 ns
= gfc_current_ns
->contained
;
3195 gfc_current_ns
->contained
= ns
->sibling
;
3196 gfc_free_namespace (ns
);
3199 if (!contains_statements
)
3200 /* This is valid in Fortran 2008. */
3201 gfc_notify_std (GFC_STD_GNU
, "Extension: CONTAINS statement without "
3202 "FUNCTION or SUBROUTINE statement at %C");
3206 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
3209 parse_progunit (gfc_statement st
)
3214 st
= parse_spec (st
);
3224 accept_statement (st
);
3231 if (gfc_current_state () == COMP_FUNCTION
)
3232 gfc_check_function_type (gfc_current_ns
);
3237 st
= parse_executable (st
);
3248 accept_statement (st
);
3255 unexpected_statement (st
);
3256 reject_statement ();
3257 st
= next_statement ();
3263 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3264 if (p
->state
== COMP_CONTAINS
)
3267 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
3272 gfc_error ("CONTAINS statement at %C is already in a contained "
3274 st
= next_statement ();
3278 parse_contained (0);
3281 gfc_current_ns
->code
= gfc_state_stack
->head
;
3285 /* Come here to complain about a global symbol already in use as
3289 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
3294 where
= &gfc_current_locus
;
3304 case GSYM_SUBROUTINE
:
3305 name
= "SUBROUTINE";
3310 case GSYM_BLOCK_DATA
:
3311 name
= "BLOCK DATA";
3317 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3321 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3322 sym
->name
, where
, name
, &sym
->where
);
3326 /* Parse a block data program unit. */
3329 parse_block_data (void)
3332 static locus blank_locus
;
3333 static int blank_block
=0;
3336 gfc_current_ns
->proc_name
= gfc_new_block
;
3337 gfc_current_ns
->is_block_data
= 1;
3339 if (gfc_new_block
== NULL
)
3342 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3343 "prior BLOCK DATA at %L", &blank_locus
);
3347 blank_locus
= gfc_current_locus
;
3352 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3354 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3355 gfc_global_used(s
, NULL
);
3358 s
->type
= GSYM_BLOCK_DATA
;
3359 s
->where
= gfc_current_locus
;
3364 st
= parse_spec (ST_NONE
);
3366 while (st
!= ST_END_BLOCK_DATA
)
3368 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3369 gfc_ascii_statement (st
));
3370 reject_statement ();
3371 st
= next_statement ();
3376 /* Parse a module subprogram. */
3384 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3385 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3386 gfc_global_used(s
, NULL
);
3389 s
->type
= GSYM_MODULE
;
3390 s
->where
= gfc_current_locus
;
3394 st
= parse_spec (ST_NONE
);
3403 parse_contained (1);
3407 accept_statement (st
);
3411 gfc_error ("Unexpected %s statement in MODULE at %C",
3412 gfc_ascii_statement (st
));
3414 reject_statement ();
3415 st
= next_statement ();
3421 /* Add a procedure name to the global symbol table. */
3424 add_global_procedure (int sub
)
3428 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3431 || (s
->type
!= GSYM_UNKNOWN
3432 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3433 gfc_global_used(s
, NULL
);
3436 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3437 s
->where
= gfc_current_locus
;
3443 /* Add a program to the global symbol table. */
3446 add_global_program (void)
3450 if (gfc_new_block
== NULL
)
3452 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3454 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
3455 gfc_global_used(s
, NULL
);
3458 s
->type
= GSYM_PROGRAM
;
3459 s
->where
= gfc_current_locus
;
3465 /* Top level parser. */
3468 gfc_parse_file (void)
3470 int seen_program
, errors_before
, errors
;
3471 gfc_state_data top
, s
;
3475 gfc_start_source_files ();
3477 top
.state
= COMP_NONE
;
3479 top
.previous
= NULL
;
3480 top
.head
= top
.tail
= NULL
;
3481 top
.do_variable
= NULL
;
3483 gfc_state_stack
= &top
;
3485 gfc_clear_new_st ();
3487 gfc_statement_label
= NULL
;
3489 if (setjmp (eof_buf
))
3490 return FAILURE
; /* Come here on unexpected EOF */
3494 /* Exit early for empty files. */
3500 st
= next_statement ();
3509 goto duplicate_main
;
3511 prog_locus
= gfc_current_locus
;
3513 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3514 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
3515 accept_statement (st
);
3516 add_global_program ();
3517 parse_progunit (ST_NONE
);
3521 add_global_procedure (1);
3522 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
3523 accept_statement (st
);
3524 parse_progunit (ST_NONE
);
3528 add_global_procedure (0);
3529 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
3530 accept_statement (st
);
3531 parse_progunit (ST_NONE
);
3535 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
3536 accept_statement (st
);
3537 parse_block_data ();
3541 push_state (&s
, COMP_MODULE
, gfc_new_block
);
3542 accept_statement (st
);
3544 gfc_get_errors (NULL
, &errors_before
);
3548 /* Anything else starts a nameless main program block. */
3551 goto duplicate_main
;
3553 prog_locus
= gfc_current_locus
;
3555 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3556 main_program_symbol (gfc_current_ns
, "MAIN__");
3557 parse_progunit (st
);
3561 gfc_current_ns
->code
= s
.head
;
3563 gfc_resolve (gfc_current_ns
);
3565 /* Dump the parse tree if requested. */
3566 if (gfc_option
.verbose
)
3567 gfc_show_namespace (gfc_current_ns
);
3569 gfc_get_errors (NULL
, &errors
);
3570 if (s
.state
== COMP_MODULE
)
3572 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
3574 gfc_generate_module_code (gfc_current_ns
);
3579 gfc_generate_code (gfc_current_ns
);
3587 gfc_end_source_files ();
3591 /* If we see a duplicate main program, shut down. If the second
3592 instance is an implied main program, ie data decls or executable
3593 statements, we're in for lots of errors. */
3594 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
3595 reject_statement ();