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 decode_statement (void)
100 gfc_clear_error (); /* Clear any pending errors. */
101 gfc_clear_warning (); /* Clear any pending warnings. */
103 if (gfc_match_eos () == MATCH_YES
)
106 old_locus
= gfc_current_locus
;
108 /* Try matching a data declaration or function declaration. The
109 input "REALFUNCTIONA(N)" can mean several things in different
110 contexts, so it (and its relatives) get special treatment. */
112 if (gfc_current_state () == COMP_NONE
113 || gfc_current_state () == COMP_INTERFACE
114 || gfc_current_state () == COMP_CONTAINS
)
116 m
= gfc_match_function_decl ();
119 else if (m
== MATCH_ERROR
)
123 gfc_current_locus
= old_locus
;
126 /* Match statements whose error messages are meant to be overwritten
127 by something better. */
129 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
130 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
131 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
133 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
134 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
136 /* Try to match a subroutine statement, which has the same optional
137 prefixes that functions can have. */
139 if (gfc_match_subroutine () == MATCH_YES
)
140 return ST_SUBROUTINE
;
142 gfc_current_locus
= old_locus
;
144 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
145 might begin with a block label. The match functions for these
146 statements are unusual in that their keyword is not seen before
147 the matcher is called. */
149 if (gfc_match_if (&st
) == MATCH_YES
)
152 gfc_current_locus
= old_locus
;
154 if (gfc_match_where (&st
) == MATCH_YES
)
157 gfc_current_locus
= old_locus
;
159 if (gfc_match_forall (&st
) == MATCH_YES
)
162 gfc_current_locus
= old_locus
;
164 match (NULL
, gfc_match_do
, ST_DO
);
165 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
167 /* General statement matching: Instead of testing every possible
168 statement, we eliminate most possibilities by peeking at the
171 c
= gfc_peek_char ();
176 match ("abstract% interface", gfc_match_abstract_interface
,
178 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
179 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
180 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
184 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
185 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
186 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
190 match ("call", gfc_match_call
, ST_CALL
);
191 match ("close", gfc_match_close
, ST_CLOSE
);
192 match ("continue", gfc_match_continue
, ST_CONTINUE
);
193 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
194 match ("case", gfc_match_case
, ST_CASE
);
195 match ("common", gfc_match_common
, ST_COMMON
);
196 match ("contains", gfc_match_eos
, ST_CONTAINS
);
200 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
201 match ("data", gfc_match_data
, ST_DATA
);
202 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
206 match ("end file", gfc_match_endfile
, ST_END_FILE
);
207 match ("exit", gfc_match_exit
, ST_EXIT
);
208 match ("else", gfc_match_else
, ST_ELSE
);
209 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
210 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
211 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
213 if (gfc_match_end (&st
) == MATCH_YES
)
216 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
217 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
218 match ("external", gfc_match_external
, ST_ATTR_DECL
);
222 match ("flush", gfc_match_flush
, ST_FLUSH
);
223 match ("format", gfc_match_format
, ST_FORMAT
);
227 match ("go to", gfc_match_goto
, ST_GOTO
);
231 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
232 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
233 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
234 match ("import", gfc_match_import
, ST_IMPORT
);
235 match ("interface", gfc_match_interface
, ST_INTERFACE
);
236 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
237 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
241 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
242 match ("module", gfc_match_module
, ST_MODULE
);
246 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
247 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
251 match ("open", gfc_match_open
, ST_OPEN
);
252 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
256 match ("print", gfc_match_print
, ST_WRITE
);
257 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
258 match ("pause", gfc_match_pause
, ST_PAUSE
);
259 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
260 if (gfc_match_private (&st
) == MATCH_YES
)
262 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
263 match ("program", gfc_match_program
, ST_PROGRAM
);
264 if (gfc_match_public (&st
) == MATCH_YES
)
266 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
270 match ("read", gfc_match_read
, ST_READ
);
271 match ("return", gfc_match_return
, ST_RETURN
);
272 match ("rewind", gfc_match_rewind
, ST_REWIND
);
276 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
277 match ("stop", gfc_match_stop
, ST_STOP
);
278 match ("save", gfc_match_save
, ST_ATTR_DECL
);
282 match ("target", gfc_match_target
, ST_ATTR_DECL
);
283 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
287 match ("use", gfc_match_use
, ST_USE
);
291 match ("value", gfc_match_value
, ST_ATTR_DECL
);
292 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
296 match ("write", gfc_match_write
, ST_WRITE
);
300 /* All else has failed, so give up. See if any of the matchers has
301 stored an error message of some sort. */
303 if (gfc_error_check () == 0)
304 gfc_error_now ("Unclassifiable statement at %C");
308 gfc_error_recovery ();
314 decode_omp_directive (void)
323 gfc_clear_error (); /* Clear any pending errors. */
324 gfc_clear_warning (); /* Clear any pending warnings. */
328 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
329 "or ELEMENTAL procedures");
330 gfc_error_recovery ();
334 old_locus
= gfc_current_locus
;
336 /* General OpenMP directive matching: Instead of testing every possible
337 statement, we eliminate most possibilities by peeking at the
340 c
= gfc_peek_char ();
345 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
348 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
351 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
354 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
357 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
358 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
359 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
360 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
361 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
362 match ("end parallel sections", gfc_match_omp_eos
,
363 ST_OMP_END_PARALLEL_SECTIONS
);
364 match ("end parallel workshare", gfc_match_omp_eos
,
365 ST_OMP_END_PARALLEL_WORKSHARE
);
366 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
367 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
368 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
369 match ("end workshare", gfc_match_omp_end_nowait
,
370 ST_OMP_END_WORKSHARE
);
373 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
376 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
379 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
382 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
383 match ("parallel sections", gfc_match_omp_parallel_sections
,
384 ST_OMP_PARALLEL_SECTIONS
);
385 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
386 ST_OMP_PARALLEL_WORKSHARE
);
387 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
390 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
391 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
392 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
395 match ("threadprivate", gfc_match_omp_threadprivate
,
396 ST_OMP_THREADPRIVATE
);
398 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
402 /* All else has failed, so give up. See if any of the matchers has
403 stored an error message of some sort. */
405 if (gfc_error_check () == 0)
406 gfc_error_now ("Unclassifiable OpenMP directive at %C");
410 gfc_error_recovery ();
418 /* Get the next statement in free form source. */
424 int c
, d
, cnt
, at_bol
;
426 at_bol
= gfc_at_bol ();
427 gfc_gobble_whitespace ();
429 c
= gfc_peek_char ();
433 /* Found a statement label? */
434 m
= gfc_match_st_label (&gfc_statement_label
);
436 d
= gfc_peek_char ();
437 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
439 gfc_match_small_literal_int (&c
, &cnt
);
442 gfc_error_now ("Too many digits in statement label at %C");
445 gfc_error_now ("Zero is not a valid statement label at %C");
448 c
= gfc_next_char ();
451 if (!gfc_is_whitespace (c
))
452 gfc_error_now ("Non-numeric character in statement label at %C");
458 label_locus
= gfc_current_locus
;
460 gfc_gobble_whitespace ();
462 if (at_bol
&& gfc_peek_char () == ';')
464 gfc_error_now ("Semicolon at %C needs to be preceded by "
466 gfc_next_char (); /* Eat up the semicolon. */
470 if (gfc_match_eos () == MATCH_YES
)
472 gfc_warning_now ("Ignoring statement label in empty statement "
474 gfc_free_st_label (gfc_statement_label
);
475 gfc_statement_label
= NULL
;
482 /* Comments have already been skipped by the time we get here,
483 except for OpenMP directives. */
484 if (gfc_option
.flag_openmp
)
488 c
= gfc_next_char ();
489 for (i
= 0; i
< 5; i
++, c
= gfc_next_char ())
490 gcc_assert (c
== "!$omp"[i
]);
492 gcc_assert (c
== ' ');
493 gfc_gobble_whitespace ();
494 return decode_omp_directive ();
498 if (at_bol
&& c
== ';')
500 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
501 gfc_next_char (); /* Eat up the semicolon. */
505 return decode_statement ();
509 /* Get the next statement in fixed-form source. */
514 int label
, digit_flag
, i
;
519 return decode_statement ();
521 /* Skip past the current label field, parsing a statement label if
522 one is there. This is a weird number parser, since the number is
523 contained within five columns and can have any kind of embedded
524 spaces. We also check for characters that make the rest of the
530 for (i
= 0; i
< 5; i
++)
532 c
= gfc_next_char_literal (0);
549 label
= label
* 10 + c
- '0';
550 label_locus
= gfc_current_locus
;
554 /* Comments have already been skipped by the time we get
555 here, except for OpenMP directives. */
557 if (gfc_option
.flag_openmp
)
559 for (i
= 0; i
< 5; i
++, c
= gfc_next_char_literal (0))
560 gcc_assert (TOLOWER (c
) == "*$omp"[i
]);
562 if (c
!= ' ' && c
!= '0')
564 gfc_buffer_error (0);
565 gfc_error ("Bad continuation line at %C");
569 return decode_omp_directive ();
573 /* Comments have already been skipped by the time we get
574 here so don't bother checking for them. */
577 gfc_buffer_error (0);
578 gfc_error ("Non-numeric character in statement label at %C");
586 gfc_warning_now ("Zero is not a valid statement label at %C");
589 /* We've found a valid statement label. */
590 gfc_statement_label
= gfc_get_st_label (label
);
594 /* Since this line starts a statement, it cannot be a continuation
595 of a previous statement. If we see something here besides a
596 space or zero, it must be a bad continuation line. */
598 c
= gfc_next_char_literal (0);
602 if (c
!= ' ' && c
!= '0')
604 gfc_buffer_error (0);
605 gfc_error ("Bad continuation line at %C");
609 /* Now that we've taken care of the statement label columns, we have
610 to make sure that the first nonblank character is not a '!'. If
611 it is, the rest of the line is a comment. */
615 loc
= gfc_current_locus
;
616 c
= gfc_next_char_literal (0);
618 while (gfc_is_whitespace (c
));
622 gfc_current_locus
= loc
;
626 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
630 if (gfc_match_eos () == MATCH_YES
)
633 /* At this point, we've got a nonblank statement to parse. */
634 return decode_statement ();
638 gfc_warning ("Ignoring statement label in empty statement at %C");
644 /* Return the next non-ST_NONE statement to the caller. We also worry
645 about including files and the ends of include files at this stage. */
648 next_statement (void)
652 gfc_new_block
= NULL
;
656 gfc_statement_label
= NULL
;
657 gfc_buffer_error (1);
661 if ((gfc_option
.warn_line_truncation
|| gfc_current_form
== FORM_FREE
)
662 && gfc_current_locus
.lb
663 && gfc_current_locus
.lb
->truncated
)
664 gfc_warning_now ("Line truncated at %C");
669 gfc_skip_comments ();
677 if (gfc_define_undef_line ())
680 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
686 gfc_buffer_error (0);
689 check_statement_label (st
);
695 /****************************** Parser ***********************************/
697 /* The parser subroutines are of type 'try' that fail if the file ends
700 /* Macros that expand to case-labels for various classes of
701 statements. Start with executable statements that directly do
704 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
705 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
706 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
707 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
708 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
709 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
710 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
711 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
714 /* Statements that mark other executable statements. */
716 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
717 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
718 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
719 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
720 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
721 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
723 /* Declaration statements */
725 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
726 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
727 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
730 /* Block end statements. Errors associated with interchanging these
731 are detected in gfc_match_end(). */
733 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
734 case ST_END_PROGRAM: case ST_END_SUBROUTINE
737 /* Push a new state onto the stack. */
740 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
742 p
->state
= new_state
;
743 p
->previous
= gfc_state_stack
;
745 p
->head
= p
->tail
= NULL
;
746 p
->do_variable
= NULL
;
751 /* Pop the current state. */
755 gfc_state_stack
= gfc_state_stack
->previous
;
759 /* Try to find the given state in the state stack. */
762 gfc_find_state (gfc_compile_state state
)
766 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
767 if (p
->state
== state
)
770 return (p
== NULL
) ? FAILURE
: SUCCESS
;
774 /* Starts a new level in the statement list. */
777 new_level (gfc_code
*q
)
781 p
= q
->block
= gfc_get_code ();
783 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
789 /* Add the current new_st code structure and adds it to the current
790 program unit. As a side-effect, it zeroes the new_st. */
800 p
->loc
= gfc_current_locus
;
802 if (gfc_state_stack
->head
== NULL
)
803 gfc_state_stack
->head
= p
;
805 gfc_state_stack
->tail
->next
= p
;
807 while (p
->next
!= NULL
)
810 gfc_state_stack
->tail
= p
;
818 /* Frees everything associated with the current statement. */
821 undo_new_statement (void)
823 gfc_free_statements (new_st
.block
);
824 gfc_free_statements (new_st
.next
);
825 gfc_free_statement (&new_st
);
830 /* If the current statement has a statement label, make sure that it
831 is allowed to, or should have one. */
834 check_statement_label (gfc_statement st
)
838 if (gfc_statement_label
== NULL
)
841 gfc_error ("FORMAT statement at %L does not have a statement label",
849 case ST_END_FUNCTION
:
850 case ST_END_SUBROUTINE
:
856 type
= ST_LABEL_TARGET
;
860 type
= ST_LABEL_FORMAT
;
863 /* Statement labels are not restricted from appearing on a
864 particular line. However, there are plenty of situations
865 where the resulting label can't be referenced. */
868 type
= ST_LABEL_BAD_TARGET
;
872 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
874 new_st
.here
= gfc_statement_label
;
878 /* Figures out what the enclosing program unit is. This will be a
879 function, subroutine, program, block data or module. */
882 gfc_enclosing_unit (gfc_compile_state
* result
)
886 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
887 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
888 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
889 || p
->state
== COMP_PROGRAM
)
898 *result
= COMP_PROGRAM
;
903 /* Translate a statement enum to a string. */
906 gfc_ascii_statement (gfc_statement st
)
912 case ST_ARITHMETIC_IF
:
913 p
= _("arithmetic IF");
919 p
= _("attribute declaration");
949 p
= _("data declaration");
957 case ST_DERIVED_DECL
:
958 p
= _("derived type declaration");
972 case ST_END_BLOCK_DATA
:
973 p
= "END BLOCK DATA";
984 case ST_END_FUNCTION
:
990 case ST_END_INTERFACE
:
1002 case ST_END_SUBROUTINE
:
1003 p
= "END SUBROUTINE";
1014 case ST_EQUIVALENCE
:
1023 case ST_FORALL_BLOCK
: /* Fall through */
1042 case ST_IMPLICIT_NONE
:
1043 p
= "IMPLICIT NONE";
1045 case ST_IMPLIED_ENDDO
:
1046 p
= _("implied END DO");
1072 case ST_MODULE_PROC
:
1073 p
= "MODULE PROCEDURE";
1111 case ST_WHERE_BLOCK
: /* Fall through */
1119 p
= _("assignment");
1121 case ST_POINTER_ASSIGNMENT
:
1122 p
= _("pointer assignment");
1124 case ST_SELECT_CASE
:
1133 case ST_STATEMENT_FUNCTION
:
1134 p
= "STATEMENT FUNCTION";
1136 case ST_LABEL_ASSIGNMENT
:
1137 p
= "LABEL ASSIGNMENT";
1140 p
= "ENUM DEFINITION";
1143 p
= "ENUMERATOR DEFINITION";
1151 case ST_OMP_BARRIER
:
1152 p
= "!$OMP BARRIER";
1154 case ST_OMP_CRITICAL
:
1155 p
= "!$OMP CRITICAL";
1160 case ST_OMP_END_CRITICAL
:
1161 p
= "!$OMP END CRITICAL";
1166 case ST_OMP_END_MASTER
:
1167 p
= "!$OMP END MASTER";
1169 case ST_OMP_END_ORDERED
:
1170 p
= "!$OMP END ORDERED";
1172 case ST_OMP_END_PARALLEL
:
1173 p
= "!$OMP END PARALLEL";
1175 case ST_OMP_END_PARALLEL_DO
:
1176 p
= "!$OMP END PARALLEL DO";
1178 case ST_OMP_END_PARALLEL_SECTIONS
:
1179 p
= "!$OMP END PARALLEL SECTIONS";
1181 case ST_OMP_END_PARALLEL_WORKSHARE
:
1182 p
= "!$OMP END PARALLEL WORKSHARE";
1184 case ST_OMP_END_SECTIONS
:
1185 p
= "!$OMP END SECTIONS";
1187 case ST_OMP_END_SINGLE
:
1188 p
= "!$OMP END SINGLE";
1190 case ST_OMP_END_WORKSHARE
:
1191 p
= "!$OMP END WORKSHARE";
1199 case ST_OMP_ORDERED
:
1200 p
= "!$OMP ORDERED";
1202 case ST_OMP_PARALLEL
:
1203 p
= "!$OMP PARALLEL";
1205 case ST_OMP_PARALLEL_DO
:
1206 p
= "!$OMP PARALLEL DO";
1208 case ST_OMP_PARALLEL_SECTIONS
:
1209 p
= "!$OMP PARALLEL SECTIONS";
1211 case ST_OMP_PARALLEL_WORKSHARE
:
1212 p
= "!$OMP PARALLEL WORKSHARE";
1214 case ST_OMP_SECTIONS
:
1215 p
= "!$OMP SECTIONS";
1217 case ST_OMP_SECTION
:
1218 p
= "!$OMP SECTION";
1223 case ST_OMP_THREADPRIVATE
:
1224 p
= "!$OMP THREADPRIVATE";
1226 case ST_OMP_WORKSHARE
:
1227 p
= "!$OMP WORKSHARE";
1230 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1237 /* Create a symbol for the main program and assign it to ns->proc_name. */
1240 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1242 gfc_symbol
*main_program
;
1243 symbol_attribute attr
;
1245 gfc_get_symbol (name
, ns
, &main_program
);
1246 gfc_clear_attr (&attr
);
1247 attr
.flavor
= FL_PROGRAM
;
1248 attr
.proc
= PROC_UNKNOWN
;
1249 attr
.subroutine
= 1;
1250 attr
.access
= ACCESS_PUBLIC
;
1251 attr
.is_main_program
= 1;
1252 main_program
->attr
= attr
;
1253 main_program
->declared_at
= gfc_current_locus
;
1254 ns
->proc_name
= main_program
;
1255 gfc_commit_symbols ();
1259 /* Do whatever is necessary to accept the last statement. */
1262 accept_statement (gfc_statement st
)
1270 case ST_IMPLICIT_NONE
:
1271 gfc_set_implicit_none ();
1280 gfc_current_ns
->proc_name
= gfc_new_block
;
1283 /* If the statement is the end of a block, lay down a special code
1284 that allows a branch to the end of the block from within the
1289 if (gfc_statement_label
!= NULL
)
1291 new_st
.op
= EXEC_NOP
;
1297 /* The end-of-program unit statements do not get the special
1298 marker and require a statement of some sort if they are a
1301 case ST_END_PROGRAM
:
1302 case ST_END_FUNCTION
:
1303 case ST_END_SUBROUTINE
:
1304 if (gfc_statement_label
!= NULL
)
1306 new_st
.op
= EXEC_RETURN
;
1322 gfc_commit_symbols ();
1323 gfc_warning_check ();
1324 gfc_clear_new_st ();
1328 /* Undo anything tentative that has been built for the current
1332 reject_statement (void)
1334 gfc_new_block
= NULL
;
1335 gfc_undo_symbols ();
1336 gfc_clear_warning ();
1337 undo_new_statement ();
1341 /* Generic complaint about an out of order statement. We also do
1342 whatever is necessary to clean up. */
1345 unexpected_statement (gfc_statement st
)
1347 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1349 reject_statement ();
1353 /* Given the next statement seen by the matcher, make sure that it is
1354 in proper order with the last. This subroutine is initialized by
1355 calling it with an argument of ST_NONE. If there is a problem, we
1356 issue an error and return FAILURE. Otherwise we return SUCCESS.
1358 Individual parsers need to verify that the statements seen are
1359 valid before calling here, ie ENTRY statements are not allowed in
1360 INTERFACE blocks. The following diagram is taken from the standard:
1362 +---------------------------------------+
1363 | program subroutine function module |
1364 +---------------------------------------+
1366 +---------------------------------------+
1368 +---------------------------------------+
1370 | +-----------+------------------+
1371 | | parameter | implicit |
1372 | +-----------+------------------+
1373 | format | | derived type |
1374 | entry | parameter | interface |
1375 | | data | specification |
1376 | | | statement func |
1377 | +-----------+------------------+
1378 | | data | executable |
1379 +--------+-----------+------------------+
1381 +---------------------------------------+
1382 | internal module/subprogram |
1383 +---------------------------------------+
1385 +---------------------------------------+
1392 { ORDER_START
, ORDER_USE
, ORDER_IMPORT
, ORDER_IMPLICIT_NONE
,
1393 ORDER_IMPLICIT
, ORDER_SPEC
, ORDER_EXEC
1396 gfc_statement last_statement
;
1402 verify_st_order (st_state
*p
, gfc_statement st
)
1408 p
->state
= ORDER_START
;
1412 if (p
->state
> ORDER_USE
)
1414 p
->state
= ORDER_USE
;
1418 if (p
->state
> ORDER_IMPORT
)
1420 p
->state
= ORDER_IMPORT
;
1423 case ST_IMPLICIT_NONE
:
1424 if (p
->state
> ORDER_IMPLICIT_NONE
)
1427 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1428 statement disqualifies a USE but not an IMPLICIT NONE.
1429 Duplicate IMPLICIT NONEs are caught when the implicit types
1432 p
->state
= ORDER_IMPLICIT_NONE
;
1436 if (p
->state
> ORDER_IMPLICIT
)
1438 p
->state
= ORDER_IMPLICIT
;
1443 if (p
->state
< ORDER_IMPLICIT_NONE
)
1444 p
->state
= ORDER_IMPLICIT_NONE
;
1448 if (p
->state
>= ORDER_EXEC
)
1450 if (p
->state
< ORDER_IMPLICIT
)
1451 p
->state
= ORDER_IMPLICIT
;
1455 if (p
->state
< ORDER_SPEC
)
1456 p
->state
= ORDER_SPEC
;
1461 case ST_DERIVED_DECL
:
1463 if (p
->state
>= ORDER_EXEC
)
1465 if (p
->state
< ORDER_SPEC
)
1466 p
->state
= ORDER_SPEC
;
1471 if (p
->state
< ORDER_EXEC
)
1472 p
->state
= ORDER_EXEC
;
1476 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1477 gfc_ascii_statement (st
));
1480 /* All is well, record the statement in case we need it next time. */
1481 p
->where
= gfc_current_locus
;
1482 p
->last_statement
= st
;
1486 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1487 gfc_ascii_statement (st
),
1488 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1494 /* Handle an unexpected end of file. This is a show-stopper... */
1496 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1499 unexpected_eof (void)
1503 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1505 /* Memory cleanup. Move to "second to last". */
1506 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1509 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1512 longjmp (eof_buf
, 1);
1516 /* Parse a derived type. */
1519 parse_derived (void)
1521 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1524 gfc_symbol
*derived_sym
= NULL
;
1530 accept_statement (ST_DERIVED_DECL
);
1531 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1533 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1540 while (compiling_type
)
1542 st
= next_statement ();
1550 accept_statement (st
);
1558 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
1559 "definition at %C without components")
1563 accept_statement (ST_END_TYPE
);
1567 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1569 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1577 gfc_error ("PRIVATE statement at %C must precede "
1578 "structure components");
1585 gfc_error ("Duplicate PRIVATE statement at %C");
1589 s
.sym
->component_access
= ACCESS_PRIVATE
;
1590 accept_statement (ST_PRIVATE
);
1597 gfc_error ("SEQUENCE statement at %C must precede "
1598 "structure components");
1603 if (gfc_current_block ()->attr
.sequence
)
1604 gfc_warning ("SEQUENCE attribute at %C already specified in "
1609 gfc_error ("Duplicate SEQUENCE statement at %C");
1614 gfc_add_sequence (&gfc_current_block ()->attr
,
1615 gfc_current_block ()->name
, NULL
);
1619 unexpected_statement (st
);
1624 /* need to verify that all fields of the derived type are
1625 * interoperable with C if the type is declared to be bind(c)
1627 derived_sym
= gfc_current_block();
1629 sym
= gfc_current_block ();
1630 for (c
= sym
->components
; c
; c
= c
->next
)
1632 /* Look for allocatable components. */
1634 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.alloc_comp
))
1636 sym
->attr
.alloc_comp
= 1;
1640 /* Look for pointer components. */
1642 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.pointer_comp
))
1644 sym
->attr
.pointer_comp
= 1;
1648 /* Look for private components. */
1649 if (sym
->component_access
== ACCESS_PRIVATE
1650 || c
->access
== ACCESS_PRIVATE
1651 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.private_comp
))
1653 sym
->attr
.private_comp
= 1;
1658 if (!seen_component
)
1659 sym
->attr
.zero_comp
= 1;
1665 /* Parse an ENUM. */
1674 int seen_enumerator
= 0;
1678 push_state (&s
, COMP_ENUM
, gfc_new_block
);
1682 while (compiling_enum
)
1684 st
= next_statement ();
1692 seen_enumerator
= 1;
1693 accept_statement (st
);
1698 if (!seen_enumerator
)
1700 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1703 accept_statement (st
);
1707 gfc_free_enum_history ();
1708 unexpected_statement (st
);
1716 /* Parse an interface. We must be able to deal with the possibility
1717 of recursive interfaces. The parse_spec() subroutine is mutually
1718 recursive with parse_interface(). */
1720 static gfc_statement
parse_spec (gfc_statement
);
1723 parse_interface (void)
1725 gfc_compile_state new_state
, current_state
;
1726 gfc_symbol
*prog_unit
, *sym
;
1727 gfc_interface_info save
;
1728 gfc_state_data s1
, s2
;
1732 accept_statement (ST_INTERFACE
);
1734 current_interface
.ns
= gfc_current_ns
;
1735 save
= current_interface
;
1737 sym
= (current_interface
.type
== INTERFACE_GENERIC
1738 || current_interface
.type
== INTERFACE_USER_OP
)
1739 ? gfc_new_block
: NULL
;
1741 push_state (&s1
, COMP_INTERFACE
, sym
);
1742 current_state
= COMP_NONE
;
1745 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1747 st
= next_statement ();
1754 new_state
= COMP_SUBROUTINE
;
1755 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1756 gfc_new_block
->formal
, NULL
);
1760 new_state
= COMP_FUNCTION
;
1761 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1762 gfc_new_block
->formal
, NULL
);
1766 case ST_MODULE_PROC
: /* The module procedure matcher makes
1767 sure the context is correct. */
1768 accept_statement (st
);
1769 gfc_free_namespace (gfc_current_ns
);
1772 case ST_END_INTERFACE
:
1773 gfc_free_namespace (gfc_current_ns
);
1774 gfc_current_ns
= current_interface
.ns
;
1778 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1779 gfc_ascii_statement (st
));
1780 reject_statement ();
1781 gfc_free_namespace (gfc_current_ns
);
1786 /* Make sure that a generic interface has only subroutines or
1787 functions and that the generic name has the right attribute. */
1788 if (current_interface
.type
== INTERFACE_GENERIC
)
1790 if (current_state
== COMP_NONE
)
1792 if (new_state
== COMP_FUNCTION
)
1793 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1794 else if (new_state
== COMP_SUBROUTINE
)
1795 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1797 current_state
= new_state
;
1801 if (new_state
!= current_state
)
1803 if (new_state
== COMP_SUBROUTINE
)
1804 gfc_error ("SUBROUTINE at %C does not belong in a "
1805 "generic function interface");
1807 if (new_state
== COMP_FUNCTION
)
1808 gfc_error ("FUNCTION at %C does not belong in a "
1809 "generic subroutine interface");
1814 if (current_interface
.type
== INTERFACE_ABSTRACT
)
1816 gfc_new_block
->attr
.abstract
= 1;
1817 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
1818 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1819 "cannot be the same as an intrinsic type",
1820 gfc_new_block
->name
);
1823 push_state (&s2
, new_state
, gfc_new_block
);
1824 accept_statement (st
);
1825 prog_unit
= gfc_new_block
;
1826 prog_unit
->formal_ns
= gfc_current_ns
;
1827 proc_locus
= gfc_current_locus
;
1830 /* Read data declaration statements. */
1831 st
= parse_spec (ST_NONE
);
1833 /* Since the interface block does not permit an IMPLICIT statement,
1834 the default type for the function or the result must be taken
1835 from the formal namespace. */
1836 if (new_state
== COMP_FUNCTION
)
1838 if (prog_unit
->result
== prog_unit
1839 && prog_unit
->ts
.type
== BT_UNKNOWN
)
1840 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
1841 else if (prog_unit
->result
!= prog_unit
1842 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
1843 gfc_set_default_type (prog_unit
->result
, 1,
1844 prog_unit
->formal_ns
);
1847 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1849 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1850 gfc_ascii_statement (st
));
1851 reject_statement ();
1855 current_interface
= save
;
1856 gfc_add_interface (prog_unit
);
1859 if (current_interface
.ns
1860 && current_interface
.ns
->proc_name
1861 && strcmp (current_interface
.ns
->proc_name
->name
,
1862 prog_unit
->name
) == 0)
1863 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
1864 "enclosing procedure", prog_unit
->name
, &proc_locus
);
1873 /* Recover use associated or imported function characteristics. */
1876 match_deferred_characteristics (gfc_typespec
* ts
)
1881 loc
= gfc_current_locus
;
1883 if (gfc_current_block ()->ts
.type
!= BT_UNKNOWN
)
1885 /* Kind expression for an intrinsic type. */
1886 gfc_current_locus
= gfc_function_kind_locus
;
1887 m
= gfc_match_kind_spec (ts
, true);
1891 /* A derived type. */
1892 gfc_current_locus
= gfc_function_type_locus
;
1893 m
= gfc_match_type_spec (ts
, 0);
1896 gfc_current_ns
->proc_name
->result
->ts
= *ts
;
1897 gfc_current_locus
=loc
;
1902 /* Parse a set of specification statements. Returns the statement
1903 that doesn't fit. */
1905 static gfc_statement
1906 parse_spec (gfc_statement st
)
1910 verify_st_order (&ss
, ST_NONE
);
1912 st
= next_statement ();
1922 case ST_DATA
: /* Not allowed in interfaces */
1923 if (gfc_current_state () == COMP_INTERFACE
)
1930 case ST_IMPLICIT_NONE
:
1935 case ST_DERIVED_DECL
:
1937 if (verify_st_order (&ss
, st
) == FAILURE
)
1939 reject_statement ();
1940 st
= next_statement ();
1950 case ST_DERIVED_DECL
:
1956 if (gfc_current_state () != COMP_MODULE
)
1958 gfc_error ("%s statement must appear in a MODULE",
1959 gfc_ascii_statement (st
));
1963 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1965 gfc_error ("%s statement at %C follows another accessibility "
1966 "specification", gfc_ascii_statement (st
));
1970 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1971 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1975 case ST_STATEMENT_FUNCTION
:
1976 if (gfc_current_state () == COMP_MODULE
)
1978 unexpected_statement (st
);
1986 accept_statement (st
);
1988 /* Look out for function kind/type information that used
1989 use associated or imported parameter. This is signalled
1991 if (gfc_current_state () == COMP_FUNCTION
1992 && (st
== ST_USE
|| st
== ST_IMPORT
|| st
== ST_DERIVED_DECL
)
1993 && gfc_current_block ()->ts
.kind
== -1)
1994 match_deferred_characteristics (&gfc_current_block ()->ts
);
1996 st
= next_statement ();
2000 accept_statement (st
);
2002 st
= next_statement ();
2009 /* If we still have kind = -1 at the end of the specification block,
2010 then there is an error. */
2011 if (gfc_current_state () == COMP_FUNCTION
2012 && gfc_current_block ()->ts
.kind
== -1)
2014 if (gfc_current_block ()->ts
.type
!= BT_UNKNOWN
)
2015 gfc_error ("Bad kind expression for function '%s' at %L",
2016 gfc_current_block ()->name
, &gfc_function_kind_locus
);
2018 gfc_error ("The type for function '%s' at %L is not accessible",
2019 gfc_current_block ()->name
, &gfc_function_type_locus
);
2026 /* Parse a WHERE block, (not a simple WHERE statement). */
2029 parse_where_block (void)
2031 int seen_empty_else
;
2036 accept_statement (ST_WHERE_BLOCK
);
2037 top
= gfc_state_stack
->tail
;
2039 push_state (&s
, COMP_WHERE
, gfc_new_block
);
2041 d
= add_statement ();
2042 d
->expr
= top
->expr
;
2048 seen_empty_else
= 0;
2052 st
= next_statement ();
2058 case ST_WHERE_BLOCK
:
2059 parse_where_block ();
2064 accept_statement (st
);
2068 if (seen_empty_else
)
2070 gfc_error ("ELSEWHERE statement at %C follows previous "
2071 "unmasked ELSEWHERE");
2075 if (new_st
.expr
== NULL
)
2076 seen_empty_else
= 1;
2078 d
= new_level (gfc_state_stack
->head
);
2080 d
->expr
= new_st
.expr
;
2082 accept_statement (st
);
2087 accept_statement (st
);
2091 gfc_error ("Unexpected %s statement in WHERE block at %C",
2092 gfc_ascii_statement (st
));
2093 reject_statement ();
2097 while (st
!= ST_END_WHERE
);
2103 /* Parse a FORALL block (not a simple FORALL statement). */
2106 parse_forall_block (void)
2112 accept_statement (ST_FORALL_BLOCK
);
2113 top
= gfc_state_stack
->tail
;
2115 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2117 d
= add_statement ();
2118 d
->op
= EXEC_FORALL
;
2123 st
= next_statement ();
2128 case ST_POINTER_ASSIGNMENT
:
2131 accept_statement (st
);
2134 case ST_WHERE_BLOCK
:
2135 parse_where_block ();
2138 case ST_FORALL_BLOCK
:
2139 parse_forall_block ();
2143 accept_statement (st
);
2150 gfc_error ("Unexpected %s statement in FORALL block at %C",
2151 gfc_ascii_statement (st
));
2153 reject_statement ();
2157 while (st
!= ST_END_FORALL
);
2163 static gfc_statement
parse_executable (gfc_statement
);
2165 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2168 parse_if_block (void)
2177 accept_statement (ST_IF_BLOCK
);
2179 top
= gfc_state_stack
->tail
;
2180 push_state (&s
, COMP_IF
, gfc_new_block
);
2182 new_st
.op
= EXEC_IF
;
2183 d
= add_statement ();
2185 d
->expr
= top
->expr
;
2191 st
= parse_executable (ST_NONE
);
2201 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2202 "statement at %L", &else_locus
);
2204 reject_statement ();
2208 d
= new_level (gfc_state_stack
->head
);
2210 d
->expr
= new_st
.expr
;
2212 accept_statement (st
);
2219 gfc_error ("Duplicate ELSE statements at %L and %C",
2221 reject_statement ();
2226 else_locus
= gfc_current_locus
;
2228 d
= new_level (gfc_state_stack
->head
);
2231 accept_statement (st
);
2239 unexpected_statement (st
);
2243 while (st
!= ST_ENDIF
);
2246 accept_statement (st
);
2250 /* Parse a SELECT block. */
2253 parse_select_block (void)
2259 accept_statement (ST_SELECT_CASE
);
2261 cp
= gfc_state_stack
->tail
;
2262 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2264 /* Make sure that the next statement is a CASE or END SELECT. */
2267 st
= next_statement ();
2270 if (st
== ST_END_SELECT
)
2272 /* Empty SELECT CASE is OK. */
2273 accept_statement (st
);
2280 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2283 reject_statement ();
2286 /* At this point, we're got a nonempty select block. */
2287 cp
= new_level (cp
);
2290 accept_statement (st
);
2294 st
= parse_executable (ST_NONE
);
2301 cp
= new_level (gfc_state_stack
->head
);
2303 gfc_clear_new_st ();
2305 accept_statement (st
);
2311 /* Can't have an executable statement because of
2312 parse_executable(). */
2314 unexpected_statement (st
);
2318 while (st
!= ST_END_SELECT
);
2321 accept_statement (st
);
2325 /* Given a symbol, make sure it is not an iteration variable for a DO
2326 statement. This subroutine is called when the symbol is seen in a
2327 context that causes it to become redefined. If the symbol is an
2328 iterator, we generate an error message and return nonzero. */
2331 gfc_check_do_variable (gfc_symtree
*st
)
2335 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2336 if (s
->do_variable
== st
)
2338 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2339 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2347 /* Checks to see if the current statement label closes an enddo.
2348 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2349 an error) if it incorrectly closes an ENDDO. */
2352 check_do_closure (void)
2356 if (gfc_statement_label
== NULL
)
2359 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2360 if (p
->state
== COMP_DO
)
2364 return 0; /* No loops to close */
2366 if (p
->ext
.end_do_label
== gfc_statement_label
)
2369 if (p
== gfc_state_stack
)
2372 gfc_error ("End of nonblock DO statement at %C is within another block");
2376 /* At this point, the label doesn't terminate the innermost loop.
2377 Make sure it doesn't terminate another one. */
2378 for (; p
; p
= p
->previous
)
2379 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
2381 gfc_error ("End of nonblock DO statement at %C is interwoven "
2382 "with another DO loop");
2390 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
2391 handled inside of parse_executable(), because they aren't really
2395 parse_do_block (void)
2402 s
.ext
.end_do_label
= new_st
.label
;
2404 if (new_st
.ext
.iterator
!= NULL
)
2405 stree
= new_st
.ext
.iterator
->var
->symtree
;
2409 accept_statement (ST_DO
);
2411 top
= gfc_state_stack
->tail
;
2412 push_state (&s
, COMP_DO
, gfc_new_block
);
2414 s
.do_variable
= stree
;
2416 top
->block
= new_level (top
);
2417 top
->block
->op
= EXEC_DO
;
2420 st
= parse_executable (ST_NONE
);
2428 if (s
.ext
.end_do_label
!= NULL
2429 && s
.ext
.end_do_label
!= gfc_statement_label
)
2430 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2433 if (gfc_statement_label
!= NULL
)
2435 new_st
.op
= EXEC_NOP
;
2440 case ST_IMPLIED_ENDDO
:
2441 /* If the do-stmt of this DO construct has a do-construct-name,
2442 the corresponding end-do must be an end-do-stmt (with a matching
2443 name, but in that case we must have seen ST_ENDDO first).
2444 We only complain about this in pedantic mode. */
2445 if (gfc_current_block () != NULL
)
2446 gfc_error_now ("named block DO at %L requires matching ENDDO name",
2447 &gfc_current_block()->declared_at
);
2452 unexpected_statement (st
);
2457 accept_statement (st
);
2461 /* Parse the statements of OpenMP do/parallel do. */
2463 static gfc_statement
2464 parse_omp_do (gfc_statement omp_st
)
2470 accept_statement (omp_st
);
2472 cp
= gfc_state_stack
->tail
;
2473 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2474 np
= new_level (cp
);
2480 st
= next_statement ();
2483 else if (st
== ST_DO
)
2486 unexpected_statement (st
);
2490 if (gfc_statement_label
!= NULL
2491 && gfc_state_stack
->previous
!= NULL
2492 && gfc_state_stack
->previous
->state
== COMP_DO
2493 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
2501 there should be no !$OMP END DO. */
2503 return ST_IMPLIED_ENDDO
;
2506 check_do_closure ();
2509 st
= next_statement ();
2510 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
2512 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
2513 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2515 gcc_assert (new_st
.op
== EXEC_NOP
);
2516 gfc_clear_new_st ();
2517 gfc_commit_symbols ();
2518 gfc_warning_check ();
2519 st
= next_statement ();
2525 /* Parse the statements of OpenMP atomic directive. */
2528 parse_omp_atomic (void)
2534 accept_statement (ST_OMP_ATOMIC
);
2536 cp
= gfc_state_stack
->tail
;
2537 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2538 np
= new_level (cp
);
2544 st
= next_statement ();
2547 else if (st
== ST_ASSIGNMENT
)
2550 unexpected_statement (st
);
2553 accept_statement (st
);
2559 /* Parse the statements of an OpenMP structured block. */
2562 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
2564 gfc_statement st
, omp_end_st
;
2568 accept_statement (omp_st
);
2570 cp
= gfc_state_stack
->tail
;
2571 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
2572 np
= new_level (cp
);
2578 case ST_OMP_PARALLEL
:
2579 omp_end_st
= ST_OMP_END_PARALLEL
;
2581 case ST_OMP_PARALLEL_SECTIONS
:
2582 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
2584 case ST_OMP_SECTIONS
:
2585 omp_end_st
= ST_OMP_END_SECTIONS
;
2587 case ST_OMP_ORDERED
:
2588 omp_end_st
= ST_OMP_END_ORDERED
;
2590 case ST_OMP_CRITICAL
:
2591 omp_end_st
= ST_OMP_END_CRITICAL
;
2594 omp_end_st
= ST_OMP_END_MASTER
;
2597 omp_end_st
= ST_OMP_END_SINGLE
;
2599 case ST_OMP_WORKSHARE
:
2600 omp_end_st
= ST_OMP_END_WORKSHARE
;
2602 case ST_OMP_PARALLEL_WORKSHARE
:
2603 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
2611 if (workshare_stmts_only
)
2613 /* Inside of !$omp workshare, only
2616 where statements and constructs
2617 forall statements and constructs
2621 are allowed. For !$omp critical these
2622 restrictions apply recursively. */
2625 st
= next_statement ();
2636 accept_statement (st
);
2639 case ST_WHERE_BLOCK
:
2640 parse_where_block ();
2643 case ST_FORALL_BLOCK
:
2644 parse_forall_block ();
2647 case ST_OMP_PARALLEL
:
2648 case ST_OMP_PARALLEL_SECTIONS
:
2649 parse_omp_structured_block (st
, false);
2652 case ST_OMP_PARALLEL_WORKSHARE
:
2653 case ST_OMP_CRITICAL
:
2654 parse_omp_structured_block (st
, true);
2657 case ST_OMP_PARALLEL_DO
:
2658 st
= parse_omp_do (st
);
2662 parse_omp_atomic ();
2673 st
= next_statement ();
2677 st
= parse_executable (ST_NONE
);
2680 else if (st
== ST_OMP_SECTION
2681 && (omp_st
== ST_OMP_SECTIONS
2682 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
2684 np
= new_level (np
);
2688 else if (st
!= omp_end_st
)
2689 unexpected_statement (st
);
2691 while (st
!= omp_end_st
);
2695 case EXEC_OMP_END_NOWAIT
:
2696 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
2698 case EXEC_OMP_CRITICAL
:
2699 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
2700 || (new_st
.ext
.omp_name
!= NULL
2701 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
2702 gfc_error ("Name after !$omp critical and !$omp end critical does "
2704 gfc_free (CONST_CAST (char *, new_st
.ext
.omp_name
));
2706 case EXEC_OMP_END_SINGLE
:
2707 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
2708 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
2709 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
2710 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
2718 gfc_clear_new_st ();
2719 gfc_commit_symbols ();
2720 gfc_warning_check ();
2725 /* Accept a series of executable statements. We return the first
2726 statement that doesn't fit to the caller. Any block statements are
2727 passed on to the correct handler, which usually passes the buck
2730 static gfc_statement
2731 parse_executable (gfc_statement st
)
2736 st
= next_statement ();
2740 close_flag
= check_do_closure ();
2745 case ST_END_PROGRAM
:
2748 case ST_END_FUNCTION
:
2752 case ST_END_SUBROUTINE
:
2757 case ST_SELECT_CASE
:
2758 gfc_error ("%s statement at %C cannot terminate a non-block "
2759 "DO loop", gfc_ascii_statement (st
));
2775 accept_statement (st
);
2776 if (close_flag
== 1)
2777 return ST_IMPLIED_ENDDO
;
2784 case ST_SELECT_CASE
:
2785 parse_select_block ();
2790 if (check_do_closure () == 1)
2791 return ST_IMPLIED_ENDDO
;
2794 case ST_WHERE_BLOCK
:
2795 parse_where_block ();
2798 case ST_FORALL_BLOCK
:
2799 parse_forall_block ();
2802 case ST_OMP_PARALLEL
:
2803 case ST_OMP_PARALLEL_SECTIONS
:
2804 case ST_OMP_SECTIONS
:
2805 case ST_OMP_ORDERED
:
2806 case ST_OMP_CRITICAL
:
2809 parse_omp_structured_block (st
, false);
2812 case ST_OMP_WORKSHARE
:
2813 case ST_OMP_PARALLEL_WORKSHARE
:
2814 parse_omp_structured_block (st
, true);
2818 case ST_OMP_PARALLEL_DO
:
2819 st
= parse_omp_do (st
);
2820 if (st
== ST_IMPLIED_ENDDO
)
2825 parse_omp_atomic ();
2832 st
= next_statement ();
2837 /* Parse a series of contained program units. */
2839 static void parse_progunit (gfc_statement
);
2842 /* Fix the symbols for sibling functions. These are incorrectly added to
2843 the child namespace as the parser didn't know about this procedure. */
2846 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
2850 gfc_symbol
*old_sym
;
2852 sym
->attr
.referenced
= 1;
2853 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2855 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2857 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
2860 old_sym
= st
->n
.sym
;
2861 if (old_sym
->ns
== ns
2862 && !old_sym
->attr
.contained
2864 /* By 14.6.1.3, host association should be excluded
2865 for the following. */
2866 && !(old_sym
->attr
.external
2867 || (old_sym
->ts
.type
!= BT_UNKNOWN
2868 && !old_sym
->attr
.implicit_type
)
2869 || old_sym
->attr
.flavor
== FL_PARAMETER
2870 || old_sym
->attr
.in_common
2871 || old_sym
->attr
.in_equivalence
2872 || old_sym
->attr
.data
2873 || old_sym
->attr
.dummy
2874 || old_sym
->attr
.result
2875 || old_sym
->attr
.dimension
2876 || old_sym
->attr
.allocatable
2877 || old_sym
->attr
.intrinsic
2878 || old_sym
->attr
.generic
2879 || old_sym
->attr
.flavor
== FL_NAMELIST
2880 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
2882 /* Replace it with the symbol from the parent namespace. */
2886 /* Free the old (local) symbol. */
2888 if (old_sym
->refs
== 0)
2889 gfc_free_symbol (old_sym
);
2892 /* Do the same for any contained procedures. */
2893 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2898 parse_contained (int module
)
2900 gfc_namespace
*ns
, *parent_ns
, *tmp
;
2901 gfc_state_data s1
, s2
;
2905 int contains_statements
= 0;
2908 push_state (&s1
, COMP_CONTAINS
, NULL
);
2909 parent_ns
= gfc_current_ns
;
2913 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
2915 gfc_current_ns
->sibling
= parent_ns
->contained
;
2916 parent_ns
->contained
= gfc_current_ns
;
2919 /* Process the next available statement. We come here if we got an error
2920 and rejected the last statement. */
2921 st
= next_statement ();
2930 contains_statements
= 1;
2931 accept_statement (st
);
2934 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2937 /* For internal procedures, create/update the symbol in the
2938 parent namespace. */
2942 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2943 gfc_error ("Contained procedure '%s' at %C is already "
2944 "ambiguous", gfc_new_block
->name
);
2947 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
2948 &gfc_new_block
->declared_at
) ==
2951 if (st
== ST_FUNCTION
)
2952 gfc_add_function (&sym
->attr
, sym
->name
,
2953 &gfc_new_block
->declared_at
);
2955 gfc_add_subroutine (&sym
->attr
, sym
->name
,
2956 &gfc_new_block
->declared_at
);
2960 gfc_commit_symbols ();
2963 sym
= gfc_new_block
;
2965 /* Mark this as a contained function, so it isn't replaced
2966 by other module functions. */
2967 sym
->attr
.contained
= 1;
2968 sym
->attr
.referenced
= 1;
2970 parse_progunit (ST_NONE
);
2972 /* Fix up any sibling functions that refer to this one. */
2973 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2974 /* Or refer to any of its alternate entry points. */
2975 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2976 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2978 gfc_current_ns
->code
= s2
.head
;
2979 gfc_current_ns
= parent_ns
;
2984 /* These statements are associated with the end of the host unit. */
2985 case ST_END_FUNCTION
:
2987 case ST_END_PROGRAM
:
2988 case ST_END_SUBROUTINE
:
2989 accept_statement (st
);
2993 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2994 gfc_ascii_statement (st
));
2995 reject_statement ();
3001 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
3002 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
3004 /* The first namespace in the list is guaranteed to not have
3005 anything (worthwhile) in it. */
3006 tmp
= gfc_current_ns
;
3007 gfc_current_ns
= parent_ns
;
3008 if (seen_error
&& tmp
->refs
> 1)
3009 gfc_free_namespace (tmp
);
3011 ns
= gfc_current_ns
->contained
;
3012 gfc_current_ns
->contained
= ns
->sibling
;
3013 gfc_free_namespace (ns
);
3016 if (!contains_statements
)
3017 /* This is valid in Fortran 2008. */
3018 gfc_notify_std (GFC_STD_GNU
, "Extension: CONTAINS statement without "
3019 "FUNCTION or SUBROUTINE statement at %C");
3023 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
3026 parse_progunit (gfc_statement st
)
3031 st
= parse_spec (st
);
3041 accept_statement (st
);
3048 if (gfc_current_state () == COMP_FUNCTION
)
3049 gfc_check_function_type (gfc_current_ns
);
3054 st
= parse_executable (st
);
3065 accept_statement (st
);
3072 unexpected_statement (st
);
3073 reject_statement ();
3074 st
= next_statement ();
3080 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3081 if (p
->state
== COMP_CONTAINS
)
3084 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
3089 gfc_error ("CONTAINS statement at %C is already in a contained "
3091 st
= next_statement ();
3095 parse_contained (0);
3098 gfc_current_ns
->code
= gfc_state_stack
->head
;
3102 /* Come here to complain about a global symbol already in use as
3106 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
3111 where
= &gfc_current_locus
;
3121 case GSYM_SUBROUTINE
:
3122 name
= "SUBROUTINE";
3127 case GSYM_BLOCK_DATA
:
3128 name
= "BLOCK DATA";
3134 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3138 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3139 sym
->name
, where
, name
, &sym
->where
);
3143 /* Parse a block data program unit. */
3146 parse_block_data (void)
3149 static locus blank_locus
;
3150 static int blank_block
=0;
3153 gfc_current_ns
->proc_name
= gfc_new_block
;
3154 gfc_current_ns
->is_block_data
= 1;
3156 if (gfc_new_block
== NULL
)
3159 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3160 "prior BLOCK DATA at %L", &blank_locus
);
3164 blank_locus
= gfc_current_locus
;
3169 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3171 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3172 gfc_global_used(s
, NULL
);
3175 s
->type
= GSYM_BLOCK_DATA
;
3176 s
->where
= gfc_current_locus
;
3181 st
= parse_spec (ST_NONE
);
3183 while (st
!= ST_END_BLOCK_DATA
)
3185 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3186 gfc_ascii_statement (st
));
3187 reject_statement ();
3188 st
= next_statement ();
3193 /* Parse a module subprogram. */
3201 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3202 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3203 gfc_global_used(s
, NULL
);
3206 s
->type
= GSYM_MODULE
;
3207 s
->where
= gfc_current_locus
;
3211 st
= parse_spec (ST_NONE
);
3220 parse_contained (1);
3224 accept_statement (st
);
3228 gfc_error ("Unexpected %s statement in MODULE at %C",
3229 gfc_ascii_statement (st
));
3231 reject_statement ();
3232 st
= next_statement ();
3238 /* Add a procedure name to the global symbol table. */
3241 add_global_procedure (int sub
)
3245 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3248 || (s
->type
!= GSYM_UNKNOWN
3249 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3250 gfc_global_used(s
, NULL
);
3253 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3254 s
->where
= gfc_current_locus
;
3260 /* Add a program to the global symbol table. */
3263 add_global_program (void)
3267 if (gfc_new_block
== NULL
)
3269 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3271 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
3272 gfc_global_used(s
, NULL
);
3275 s
->type
= GSYM_PROGRAM
;
3276 s
->where
= gfc_current_locus
;
3282 /* Top level parser. */
3285 gfc_parse_file (void)
3287 int seen_program
, errors_before
, errors
;
3288 gfc_state_data top
, s
;
3292 gfc_start_source_files ();
3294 top
.state
= COMP_NONE
;
3296 top
.previous
= NULL
;
3297 top
.head
= top
.tail
= NULL
;
3298 top
.do_variable
= NULL
;
3300 gfc_state_stack
= &top
;
3302 gfc_clear_new_st ();
3304 gfc_statement_label
= NULL
;
3306 if (setjmp (eof_buf
))
3307 return FAILURE
; /* Come here on unexpected EOF */
3311 /* Exit early for empty files. */
3317 st
= next_statement ();
3326 goto duplicate_main
;
3328 prog_locus
= gfc_current_locus
;
3330 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3331 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
3332 accept_statement (st
);
3333 add_global_program ();
3334 parse_progunit (ST_NONE
);
3338 add_global_procedure (1);
3339 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
3340 accept_statement (st
);
3341 parse_progunit (ST_NONE
);
3345 add_global_procedure (0);
3346 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
3347 accept_statement (st
);
3348 parse_progunit (ST_NONE
);
3352 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
3353 accept_statement (st
);
3354 parse_block_data ();
3358 push_state (&s
, COMP_MODULE
, gfc_new_block
);
3359 accept_statement (st
);
3361 gfc_get_errors (NULL
, &errors_before
);
3365 /* Anything else starts a nameless main program block. */
3368 goto duplicate_main
;
3370 prog_locus
= gfc_current_locus
;
3372 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
3373 main_program_symbol (gfc_current_ns
, "MAIN__");
3374 parse_progunit (st
);
3378 gfc_current_ns
->code
= s
.head
;
3380 gfc_resolve (gfc_current_ns
);
3382 /* Dump the parse tree if requested. */
3383 if (gfc_option
.verbose
)
3384 gfc_show_namespace (gfc_current_ns
);
3386 gfc_get_errors (NULL
, &errors
);
3387 if (s
.state
== COMP_MODULE
)
3389 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
3391 gfc_generate_module_code (gfc_current_ns
);
3396 gfc_generate_code (gfc_current_ns
);
3404 gfc_end_source_files ();
3408 /* If we see a duplicate main program, shut down. If the second
3409 instance is an implied main program, ie data decls or executable
3410 statements, we're in for lots of errors. */
3411 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
3412 reject_statement ();