2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
31 /* Current statement label. Zero means no statement label. Because new_st
32 can get wiped during statement matching, we have to keep it separate. */
34 gfc_st_label
*gfc_statement_label
;
36 static locus label_locus
;
37 static jmp_buf eof_buf
;
39 gfc_state_data
*gfc_state_stack
;
41 /* TODO: Re-order functions to kill these forward decls. */
42 static void check_statement_label (gfc_statement
);
43 static void undo_new_statement (void);
44 static void reject_statement (void);
47 /* A sort of half-matching function. We try to match the word on the
48 input with the passed string. If this succeeds, we call the
49 keyword-dependent matching function that will match the rest of the
50 statement. For single keywords, the matching subroutine is
54 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
69 gfc_current_locus
= *old_locus
;
77 /* Figure out what the next statement is, (mostly) regardless of
78 proper ordering. The do...while(0) is there to prevent if/else
81 #define match(keyword, subr, st) \
83 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
86 undo_new_statement (); \
90 /* This is a specialist version of decode_statement that is used
91 for the specification statements in a function, whose
92 characteristics are deferred into the specification statements.
93 eg.: INTEGER (king = mykind) foo ()
94 USE mymodule, ONLY mykind.....
95 The KIND parameter needs a return after USE or IMPORT, whereas
96 derived type declarations can occur anywhere, up the executable
97 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
98 out of the correct kind of specification statements. */
100 decode_specification_statement (void)
106 if (gfc_match_eos () == MATCH_YES
)
109 old_locus
= gfc_current_locus
;
111 match ("import", gfc_match_import
, ST_IMPORT
);
112 match ("use", gfc_match_use
, ST_USE
);
114 if (gfc_current_block ()->ts
.type
!= BT_DERIVED
)
117 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
118 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
119 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
121 /* General statement matching: Instead of testing every possible
122 statement, we eliminate most possibilities by peeking at the
125 c
= gfc_peek_ascii_char ();
130 match ("abstract% interface", gfc_match_abstract_interface
,
135 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
142 match ("data", gfc_match_data
, ST_DATA
);
143 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
147 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
148 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
149 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
150 match ("external", gfc_match_external
, ST_ATTR_DECL
);
154 match ("format", gfc_match_format
, ST_FORMAT
);
161 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
162 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
163 match ("interface", gfc_match_interface
, ST_INTERFACE
);
164 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
165 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
172 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
176 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
180 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
181 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
182 if (gfc_match_private (&st
) == MATCH_YES
)
184 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
185 if (gfc_match_public (&st
) == MATCH_YES
)
187 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
194 match ("save", gfc_match_save
, ST_ATTR_DECL
);
198 match ("target", gfc_match_target
, ST_ATTR_DECL
);
199 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
206 match ("value", gfc_match_value
, ST_ATTR_DECL
);
207 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
214 /* This is not a specification statement. See if any of the matchers
215 has stored an error message of some sort. */
219 gfc_buffer_error (0);
220 gfc_current_locus
= old_locus
;
222 return ST_GET_FCN_CHARACTERISTICS
;
226 /* This is the primary 'decode_statement'. */
228 decode_statement (void)
239 gfc_clear_error (); /* Clear any pending errors. */
240 gfc_clear_warning (); /* Clear any pending warnings. */
242 gfc_matching_function
= false;
244 if (gfc_match_eos () == MATCH_YES
)
247 if (gfc_current_state () == COMP_FUNCTION
248 && gfc_current_block ()->result
->ts
.kind
== -1)
249 return decode_specification_statement ();
251 old_locus
= gfc_current_locus
;
253 /* Try matching a data declaration or function declaration. The
254 input "REALFUNCTIONA(N)" can mean several things in different
255 contexts, so it (and its relatives) get special treatment. */
257 if (gfc_current_state () == COMP_NONE
258 || gfc_current_state () == COMP_INTERFACE
259 || gfc_current_state () == COMP_CONTAINS
)
261 gfc_matching_function
= true;
262 m
= gfc_match_function_decl ();
265 else if (m
== MATCH_ERROR
)
269 gfc_current_locus
= old_locus
;
271 gfc_matching_function
= false;
274 /* Match statements whose error messages are meant to be overwritten
275 by something better. */
277 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
278 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
279 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
281 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
282 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
284 /* Try to match a subroutine statement, which has the same optional
285 prefixes that functions can have. */
287 if (gfc_match_subroutine () == MATCH_YES
)
288 return ST_SUBROUTINE
;
290 gfc_current_locus
= old_locus
;
292 /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
293 might begin with a block label. The match functions for these
294 statements are unusual in that their keyword is not seen before
295 the matcher is called. */
297 if (gfc_match_if (&st
) == MATCH_YES
)
300 gfc_current_locus
= old_locus
;
302 if (gfc_match_where (&st
) == MATCH_YES
)
305 gfc_current_locus
= old_locus
;
307 if (gfc_match_forall (&st
) == MATCH_YES
)
310 gfc_current_locus
= old_locus
;
312 match (NULL
, gfc_match_block
, ST_BLOCK
);
313 match (NULL
, gfc_match_do
, ST_DO
);
314 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
315 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
317 /* General statement matching: Instead of testing every possible
318 statement, we eliminate most possibilities by peeking at the
321 c
= gfc_peek_ascii_char ();
326 match ("abstract% interface", gfc_match_abstract_interface
,
328 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
329 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
330 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
334 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
335 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
336 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
340 match ("call", gfc_match_call
, ST_CALL
);
341 match ("close", gfc_match_close
, ST_CLOSE
);
342 match ("continue", gfc_match_continue
, ST_CONTINUE
);
343 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
344 match ("case", gfc_match_case
, ST_CASE
);
345 match ("common", gfc_match_common
, ST_COMMON
);
346 match ("contains", gfc_match_eos
, ST_CONTAINS
);
347 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
351 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
352 match ("data", gfc_match_data
, ST_DATA
);
353 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
357 match ("end file", gfc_match_endfile
, ST_END_FILE
);
358 match ("exit", gfc_match_exit
, ST_EXIT
);
359 match ("else", gfc_match_else
, ST_ELSE
);
360 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
361 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
362 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
364 if (gfc_match_end (&st
) == MATCH_YES
)
367 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
368 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
369 match ("external", gfc_match_external
, ST_ATTR_DECL
);
373 match ("final", gfc_match_final_decl
, ST_FINAL
);
374 match ("flush", gfc_match_flush
, ST_FLUSH
);
375 match ("format", gfc_match_format
, ST_FORMAT
);
379 match ("generic", gfc_match_generic
, ST_GENERIC
);
380 match ("go to", gfc_match_goto
, ST_GOTO
);
384 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
385 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
386 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
387 match ("import", gfc_match_import
, ST_IMPORT
);
388 match ("interface", gfc_match_interface
, ST_INTERFACE
);
389 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
390 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
394 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
395 match ("module", gfc_match_module
, ST_MODULE
);
399 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
400 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
404 match ("open", gfc_match_open
, ST_OPEN
);
405 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
409 match ("print", gfc_match_print
, ST_WRITE
);
410 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
411 match ("pause", gfc_match_pause
, ST_PAUSE
);
412 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
413 if (gfc_match_private (&st
) == MATCH_YES
)
415 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
416 match ("program", gfc_match_program
, ST_PROGRAM
);
417 if (gfc_match_public (&st
) == MATCH_YES
)
419 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
423 match ("read", gfc_match_read
, ST_READ
);
424 match ("return", gfc_match_return
, ST_RETURN
);
425 match ("rewind", gfc_match_rewind
, ST_REWIND
);
429 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
430 match ("stop", gfc_match_stop
, ST_STOP
);
431 match ("save", gfc_match_save
, ST_ATTR_DECL
);
435 match ("target", gfc_match_target
, ST_ATTR_DECL
);
436 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
437 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
441 match ("use", gfc_match_use
, ST_USE
);
445 match ("value", gfc_match_value
, ST_ATTR_DECL
);
446 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
450 match ("wait", gfc_match_wait
, ST_WAIT
);
451 match ("write", gfc_match_write
, ST_WRITE
);
455 /* All else has failed, so give up. See if any of the matchers has
456 stored an error message of some sort. */
458 if (gfc_error_check () == 0)
459 gfc_error_now ("Unclassifiable statement at %C");
463 gfc_error_recovery ();
469 decode_omp_directive (void)
478 gfc_clear_error (); /* Clear any pending errors. */
479 gfc_clear_warning (); /* Clear any pending warnings. */
483 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
484 "or ELEMENTAL procedures");
485 gfc_error_recovery ();
489 old_locus
= gfc_current_locus
;
491 /* General OpenMP directive matching: Instead of testing every possible
492 statement, we eliminate most possibilities by peeking at the
495 c
= gfc_peek_ascii_char ();
500 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
503 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
506 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
509 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
512 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
513 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
514 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
515 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
516 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
517 match ("end parallel sections", gfc_match_omp_eos
,
518 ST_OMP_END_PARALLEL_SECTIONS
);
519 match ("end parallel workshare", gfc_match_omp_eos
,
520 ST_OMP_END_PARALLEL_WORKSHARE
);
521 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
522 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
523 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
524 match ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
525 match ("end workshare", gfc_match_omp_end_nowait
,
526 ST_OMP_END_WORKSHARE
);
529 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
532 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
535 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
538 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
539 match ("parallel sections", gfc_match_omp_parallel_sections
,
540 ST_OMP_PARALLEL_SECTIONS
);
541 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
542 ST_OMP_PARALLEL_WORKSHARE
);
543 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
546 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
547 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
548 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
551 match ("task", gfc_match_omp_task
, ST_OMP_TASK
);
552 match ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
553 match ("threadprivate", gfc_match_omp_threadprivate
,
554 ST_OMP_THREADPRIVATE
);
556 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
560 /* All else has failed, so give up. See if any of the matchers has
561 stored an error message of some sort. */
563 if (gfc_error_check () == 0)
564 gfc_error_now ("Unclassifiable OpenMP directive at %C");
568 gfc_error_recovery ();
574 decode_gcc_attribute (void)
582 gfc_clear_error (); /* Clear any pending errors. */
583 gfc_clear_warning (); /* Clear any pending warnings. */
584 old_locus
= gfc_current_locus
;
586 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
588 /* All else has failed, so give up. See if any of the matchers has
589 stored an error message of some sort. */
591 if (gfc_error_check () == 0)
592 gfc_error_now ("Unclassifiable GCC directive at %C");
596 gfc_error_recovery ();
604 /* Get the next statement in free form source. */
613 at_bol
= gfc_at_bol ();
614 gfc_gobble_whitespace ();
616 c
= gfc_peek_ascii_char ();
622 /* Found a statement label? */
623 m
= gfc_match_st_label (&gfc_statement_label
);
625 d
= gfc_peek_ascii_char ();
626 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
628 gfc_match_small_literal_int (&i
, &cnt
);
631 gfc_error_now ("Too many digits in statement label at %C");
634 gfc_error_now ("Zero is not a valid statement label at %C");
637 c
= gfc_next_ascii_char ();
640 if (!gfc_is_whitespace (c
))
641 gfc_error_now ("Non-numeric character in statement label at %C");
647 label_locus
= gfc_current_locus
;
649 gfc_gobble_whitespace ();
651 if (at_bol
&& gfc_peek_ascii_char () == ';')
653 gfc_error_now ("Semicolon at %C needs to be preceded by "
655 gfc_next_ascii_char (); /* Eat up the semicolon. */
659 if (gfc_match_eos () == MATCH_YES
)
661 gfc_warning_now ("Ignoring statement label in empty statement "
662 "at %L", &label_locus
);
663 gfc_free_st_label (gfc_statement_label
);
664 gfc_statement_label
= NULL
;
671 /* Comments have already been skipped by the time we get here,
672 except for GCC attributes and OpenMP directives. */
674 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
675 c
= gfc_peek_ascii_char ();
681 c
= gfc_next_ascii_char ();
682 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
683 gcc_assert (c
== "gcc$"[i
]);
685 gfc_gobble_whitespace ();
686 return decode_gcc_attribute ();
689 else if (c
== '$' && gfc_option
.flag_openmp
)
693 c
= gfc_next_ascii_char ();
694 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
695 gcc_assert (c
== "$omp"[i
]);
697 gcc_assert (c
== ' ' || c
== '\t');
698 gfc_gobble_whitespace ();
699 return decode_omp_directive ();
705 if (at_bol
&& c
== ';')
707 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
708 gfc_next_ascii_char (); /* Eat up the semicolon. */
712 return decode_statement ();
716 /* Get the next statement in fixed-form source. */
721 int label
, digit_flag
, i
;
726 return decode_statement ();
728 /* Skip past the current label field, parsing a statement label if
729 one is there. This is a weird number parser, since the number is
730 contained within five columns and can have any kind of embedded
731 spaces. We also check for characters that make the rest of the
737 for (i
= 0; i
< 5; i
++)
739 c
= gfc_next_char_literal (0);
756 label
= label
* 10 + ((unsigned char) c
- '0');
757 label_locus
= gfc_current_locus
;
761 /* Comments have already been skipped by the time we get
762 here, except for GCC attributes and OpenMP directives. */
765 c
= gfc_next_char_literal (0);
767 if (TOLOWER (c
) == 'g')
769 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (0))
770 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
772 return decode_gcc_attribute ();
774 else if (c
== '$' && gfc_option
.flag_openmp
)
776 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (0))
777 gcc_assert ((char) gfc_wide_tolower (c
) == "$omp"[i
]);
779 if (c
!= ' ' && c
!= '0')
781 gfc_buffer_error (0);
782 gfc_error ("Bad continuation line at %C");
786 return decode_omp_directive ();
790 /* Comments have already been skipped by the time we get
791 here so don't bother checking for them. */
794 gfc_buffer_error (0);
795 gfc_error ("Non-numeric character in statement label at %C");
803 gfc_warning_now ("Zero is not a valid statement label at %C");
806 /* We've found a valid statement label. */
807 gfc_statement_label
= gfc_get_st_label (label
);
811 /* Since this line starts a statement, it cannot be a continuation
812 of a previous statement. If we see something here besides a
813 space or zero, it must be a bad continuation line. */
815 c
= gfc_next_char_literal (0);
819 if (c
!= ' ' && c
!= '0')
821 gfc_buffer_error (0);
822 gfc_error ("Bad continuation line at %C");
826 /* Now that we've taken care of the statement label columns, we have
827 to make sure that the first nonblank character is not a '!'. If
828 it is, the rest of the line is a comment. */
832 loc
= gfc_current_locus
;
833 c
= gfc_next_char_literal (0);
835 while (gfc_is_whitespace (c
));
839 gfc_current_locus
= loc
;
843 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
847 if (gfc_match_eos () == MATCH_YES
)
850 /* At this point, we've got a nonblank statement to parse. */
851 return decode_statement ();
855 gfc_warning_now ("Ignoring statement label in empty statement at %L",
858 gfc_current_locus
.lb
->truncated
= 0;
864 /* Return the next non-ST_NONE statement to the caller. We also worry
865 about including files and the ends of include files at this stage. */
868 next_statement (void)
873 gfc_new_block
= NULL
;
875 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
878 gfc_statement_label
= NULL
;
879 gfc_buffer_error (1);
884 gfc_skip_comments ();
892 if (gfc_define_undef_line ())
895 old_locus
= gfc_current_locus
;
897 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
903 gfc_buffer_error (0);
905 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
907 gfc_free_st_label (gfc_statement_label
);
908 gfc_statement_label
= NULL
;
909 gfc_current_locus
= old_locus
;
913 check_statement_label (st
);
919 /****************************** Parser ***********************************/
921 /* The parser subroutines are of type 'try' that fail if the file ends
924 /* Macros that expand to case-labels for various classes of
925 statements. Start with executable statements that directly do
928 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
929 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
930 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
931 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
932 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
933 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
934 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
935 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
936 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT
938 /* Statements that mark other executable statements. */
940 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
941 case ST_IF_BLOCK: case ST_BLOCK: \
942 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
943 case ST_OMP_PARALLEL: \
944 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
945 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
946 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
947 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
950 /* Declaration statements */
952 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
953 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
954 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
957 /* Block end statements. Errors associated with interchanging these
958 are detected in gfc_match_end(). */
960 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
961 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
965 /* Push a new state onto the stack. */
968 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
970 p
->state
= new_state
;
971 p
->previous
= gfc_state_stack
;
973 p
->head
= p
->tail
= NULL
;
974 p
->do_variable
= NULL
;
979 /* Pop the current state. */
983 gfc_state_stack
= gfc_state_stack
->previous
;
987 /* Try to find the given state in the state stack. */
990 gfc_find_state (gfc_compile_state state
)
994 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
995 if (p
->state
== state
)
998 return (p
== NULL
) ? FAILURE
: SUCCESS
;
1002 /* Starts a new level in the statement list. */
1005 new_level (gfc_code
*q
)
1009 p
= q
->block
= gfc_get_code ();
1011 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1017 /* Add the current new_st code structure and adds it to the current
1018 program unit. As a side-effect, it zeroes the new_st. */
1021 add_statement (void)
1025 p
= gfc_get_code ();
1028 p
->loc
= gfc_current_locus
;
1030 if (gfc_state_stack
->head
== NULL
)
1031 gfc_state_stack
->head
= p
;
1033 gfc_state_stack
->tail
->next
= p
;
1035 while (p
->next
!= NULL
)
1038 gfc_state_stack
->tail
= p
;
1040 gfc_clear_new_st ();
1046 /* Frees everything associated with the current statement. */
1049 undo_new_statement (void)
1051 gfc_free_statements (new_st
.block
);
1052 gfc_free_statements (new_st
.next
);
1053 gfc_free_statement (&new_st
);
1054 gfc_clear_new_st ();
1058 /* If the current statement has a statement label, make sure that it
1059 is allowed to, or should have one. */
1062 check_statement_label (gfc_statement st
)
1066 if (gfc_statement_label
== NULL
)
1068 if (st
== ST_FORMAT
)
1069 gfc_error ("FORMAT statement at %L does not have a statement label",
1076 case ST_END_PROGRAM
:
1077 case ST_END_FUNCTION
:
1078 case ST_END_SUBROUTINE
:
1084 type
= ST_LABEL_TARGET
;
1088 type
= ST_LABEL_FORMAT
;
1091 /* Statement labels are not restricted from appearing on a
1092 particular line. However, there are plenty of situations
1093 where the resulting label can't be referenced. */
1096 type
= ST_LABEL_BAD_TARGET
;
1100 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1102 new_st
.here
= gfc_statement_label
;
1106 /* Figures out what the enclosing program unit is. This will be a
1107 function, subroutine, program, block data or module. */
1110 gfc_enclosing_unit (gfc_compile_state
* result
)
1114 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1115 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1116 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1117 || p
->state
== COMP_PROGRAM
)
1126 *result
= COMP_PROGRAM
;
1131 /* Translate a statement enum to a string. */
1134 gfc_ascii_statement (gfc_statement st
)
1140 case ST_ARITHMETIC_IF
:
1141 p
= _("arithmetic IF");
1147 p
= _("attribute declaration");
1180 p
= _("data declaration");
1188 case ST_DERIVED_DECL
:
1189 p
= _("derived type declaration");
1206 case ST_END_BLOCK_DATA
:
1207 p
= "END BLOCK DATA";
1218 case ST_END_FUNCTION
:
1224 case ST_END_INTERFACE
:
1225 p
= "END INTERFACE";
1230 case ST_END_PROGRAM
:
1236 case ST_END_SUBROUTINE
:
1237 p
= "END SUBROUTINE";
1248 case ST_EQUIVALENCE
:
1257 case ST_FORALL_BLOCK
: /* Fall through */
1279 case ST_IMPLICIT_NONE
:
1280 p
= "IMPLICIT NONE";
1282 case ST_IMPLIED_ENDDO
:
1283 p
= _("implied END DO");
1309 case ST_MODULE_PROC
:
1310 p
= "MODULE PROCEDURE";
1348 case ST_WHERE_BLOCK
: /* Fall through */
1359 p
= _("assignment");
1361 case ST_POINTER_ASSIGNMENT
:
1362 p
= _("pointer assignment");
1364 case ST_SELECT_CASE
:
1367 case ST_SELECT_TYPE
:
1382 case ST_STATEMENT_FUNCTION
:
1383 p
= "STATEMENT FUNCTION";
1385 case ST_LABEL_ASSIGNMENT
:
1386 p
= "LABEL ASSIGNMENT";
1389 p
= "ENUM DEFINITION";
1392 p
= "ENUMERATOR DEFINITION";
1400 case ST_OMP_BARRIER
:
1401 p
= "!$OMP BARRIER";
1403 case ST_OMP_CRITICAL
:
1404 p
= "!$OMP CRITICAL";
1409 case ST_OMP_END_CRITICAL
:
1410 p
= "!$OMP END CRITICAL";
1415 case ST_OMP_END_MASTER
:
1416 p
= "!$OMP END MASTER";
1418 case ST_OMP_END_ORDERED
:
1419 p
= "!$OMP END ORDERED";
1421 case ST_OMP_END_PARALLEL
:
1422 p
= "!$OMP END PARALLEL";
1424 case ST_OMP_END_PARALLEL_DO
:
1425 p
= "!$OMP END PARALLEL DO";
1427 case ST_OMP_END_PARALLEL_SECTIONS
:
1428 p
= "!$OMP END PARALLEL SECTIONS";
1430 case ST_OMP_END_PARALLEL_WORKSHARE
:
1431 p
= "!$OMP END PARALLEL WORKSHARE";
1433 case ST_OMP_END_SECTIONS
:
1434 p
= "!$OMP END SECTIONS";
1436 case ST_OMP_END_SINGLE
:
1437 p
= "!$OMP END SINGLE";
1439 case ST_OMP_END_TASK
:
1440 p
= "!$OMP END TASK";
1442 case ST_OMP_END_WORKSHARE
:
1443 p
= "!$OMP END WORKSHARE";
1451 case ST_OMP_ORDERED
:
1452 p
= "!$OMP ORDERED";
1454 case ST_OMP_PARALLEL
:
1455 p
= "!$OMP PARALLEL";
1457 case ST_OMP_PARALLEL_DO
:
1458 p
= "!$OMP PARALLEL DO";
1460 case ST_OMP_PARALLEL_SECTIONS
:
1461 p
= "!$OMP PARALLEL SECTIONS";
1463 case ST_OMP_PARALLEL_WORKSHARE
:
1464 p
= "!$OMP PARALLEL WORKSHARE";
1466 case ST_OMP_SECTIONS
:
1467 p
= "!$OMP SECTIONS";
1469 case ST_OMP_SECTION
:
1470 p
= "!$OMP SECTION";
1478 case ST_OMP_TASKWAIT
:
1479 p
= "!$OMP TASKWAIT";
1481 case ST_OMP_THREADPRIVATE
:
1482 p
= "!$OMP THREADPRIVATE";
1484 case ST_OMP_WORKSHARE
:
1485 p
= "!$OMP WORKSHARE";
1488 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1495 /* Create a symbol for the main program and assign it to ns->proc_name. */
1498 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1500 gfc_symbol
*main_program
;
1501 symbol_attribute attr
;
1503 gfc_get_symbol (name
, ns
, &main_program
);
1504 gfc_clear_attr (&attr
);
1505 attr
.flavor
= FL_PROGRAM
;
1506 attr
.proc
= PROC_UNKNOWN
;
1507 attr
.subroutine
= 1;
1508 attr
.access
= ACCESS_PUBLIC
;
1509 attr
.is_main_program
= 1;
1510 main_program
->attr
= attr
;
1511 main_program
->declared_at
= gfc_current_locus
;
1512 ns
->proc_name
= main_program
;
1513 gfc_commit_symbols ();
1517 /* Do whatever is necessary to accept the last statement. */
1520 accept_statement (gfc_statement st
)
1528 case ST_IMPLICIT_NONE
:
1529 gfc_set_implicit_none ();
1538 gfc_current_ns
->proc_name
= gfc_new_block
;
1541 /* If the statement is the end of a block, lay down a special code
1542 that allows a branch to the end of the block from within the
1543 construct. IF and SELECT are treated differently from DO
1544 (where EXEC_NOP is added inside the loop) for two
1546 1. END DO has a meaning in the sense that after a GOTO to
1547 it, the loop counter must be increased.
1548 2. IF blocks and SELECT blocks can consist of multiple
1549 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1550 Putting the label before the END IF would make the jump
1551 from, say, the ELSE IF block to the END IF illegal. */
1555 if (gfc_statement_label
!= NULL
)
1557 new_st
.op
= EXEC_END_BLOCK
;
1562 /* The end-of-program unit statements do not get the special
1563 marker and require a statement of some sort if they are a
1566 case ST_END_PROGRAM
:
1567 case ST_END_FUNCTION
:
1568 case ST_END_SUBROUTINE
:
1569 if (gfc_statement_label
!= NULL
)
1571 new_st
.op
= EXEC_RETURN
;
1576 new_st
.op
= EXEC_END_PROCEDURE
;
1592 gfc_commit_symbols ();
1593 gfc_warning_check ();
1594 gfc_clear_new_st ();
1598 /* Undo anything tentative that has been built for the current
1602 reject_statement (void)
1604 /* Revert to the previous charlen chain. */
1605 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
1606 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
1608 gfc_new_block
= NULL
;
1609 gfc_undo_symbols ();
1610 gfc_clear_warning ();
1611 undo_new_statement ();
1615 /* Generic complaint about an out of order statement. We also do
1616 whatever is necessary to clean up. */
1619 unexpected_statement (gfc_statement st
)
1621 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1623 reject_statement ();
1627 /* Given the next statement seen by the matcher, make sure that it is
1628 in proper order with the last. This subroutine is initialized by
1629 calling it with an argument of ST_NONE. If there is a problem, we
1630 issue an error and return FAILURE. Otherwise we return SUCCESS.
1632 Individual parsers need to verify that the statements seen are
1633 valid before calling here, i.e., ENTRY statements are not allowed in
1634 INTERFACE blocks. The following diagram is taken from the standard:
1636 +---------------------------------------+
1637 | program subroutine function module |
1638 +---------------------------------------+
1640 +---------------------------------------+
1642 +---------------------------------------+
1644 | +-----------+------------------+
1645 | | parameter | implicit |
1646 | +-----------+------------------+
1647 | format | | derived type |
1648 | entry | parameter | interface |
1649 | | data | specification |
1650 | | | statement func |
1651 | +-----------+------------------+
1652 | | data | executable |
1653 +--------+-----------+------------------+
1655 +---------------------------------------+
1656 | internal module/subprogram |
1657 +---------------------------------------+
1659 +---------------------------------------+
1668 ORDER_IMPLICIT_NONE
,
1676 enum state_order state
;
1677 gfc_statement last_statement
;
1683 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
1689 p
->state
= ORDER_START
;
1693 if (p
->state
> ORDER_USE
)
1695 p
->state
= ORDER_USE
;
1699 if (p
->state
> ORDER_IMPORT
)
1701 p
->state
= ORDER_IMPORT
;
1704 case ST_IMPLICIT_NONE
:
1705 if (p
->state
> ORDER_IMPLICIT_NONE
)
1708 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1709 statement disqualifies a USE but not an IMPLICIT NONE.
1710 Duplicate IMPLICIT NONEs are caught when the implicit types
1713 p
->state
= ORDER_IMPLICIT_NONE
;
1717 if (p
->state
> ORDER_IMPLICIT
)
1719 p
->state
= ORDER_IMPLICIT
;
1724 if (p
->state
< ORDER_IMPLICIT_NONE
)
1725 p
->state
= ORDER_IMPLICIT_NONE
;
1729 if (p
->state
>= ORDER_EXEC
)
1731 if (p
->state
< ORDER_IMPLICIT
)
1732 p
->state
= ORDER_IMPLICIT
;
1736 if (p
->state
< ORDER_SPEC
)
1737 p
->state
= ORDER_SPEC
;
1742 case ST_DERIVED_DECL
:
1744 if (p
->state
>= ORDER_EXEC
)
1746 if (p
->state
< ORDER_SPEC
)
1747 p
->state
= ORDER_SPEC
;
1752 if (p
->state
< ORDER_EXEC
)
1753 p
->state
= ORDER_EXEC
;
1757 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1758 gfc_ascii_statement (st
));
1761 /* All is well, record the statement in case we need it next time. */
1762 p
->where
= gfc_current_locus
;
1763 p
->last_statement
= st
;
1768 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1769 gfc_ascii_statement (st
),
1770 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1776 /* Handle an unexpected end of file. This is a show-stopper... */
1778 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1781 unexpected_eof (void)
1785 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1787 /* Memory cleanup. Move to "second to last". */
1788 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1791 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1794 longjmp (eof_buf
, 1);
1798 /* Parse the CONTAINS section of a derived type definition. */
1800 gfc_access gfc_typebound_default_access
;
1803 parse_derived_contains (void)
1806 bool seen_private
= false;
1807 bool seen_comps
= false;
1808 bool error_flag
= false;
1811 gcc_assert (gfc_current_state () == COMP_DERIVED
);
1812 gcc_assert (gfc_current_block ());
1814 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1816 if (gfc_current_block ()->attr
.sequence
)
1817 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1818 " section at %C", gfc_current_block ()->name
);
1819 if (gfc_current_block ()->attr
.is_bind_c
)
1820 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1821 " section at %C", gfc_current_block ()->name
);
1823 accept_statement (ST_CONTAINS
);
1824 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
1826 gfc_typebound_default_access
= ACCESS_PUBLIC
;
1832 st
= next_statement ();
1840 gfc_error ("Components in TYPE at %C must precede CONTAINS");
1845 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Type-bound"
1846 " procedure at %C") == FAILURE
)
1849 accept_statement (ST_PROCEDURE
);
1854 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: GENERIC binding"
1855 " at %C") == FAILURE
)
1858 accept_statement (ST_GENERIC
);
1863 if (gfc_notify_std (GFC_STD_F2003
,
1864 "Fortran 2003: FINAL procedure declaration"
1865 " at %C") == FAILURE
)
1868 accept_statement (ST_FINAL
);
1876 && (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Derived type "
1877 "definition at %C with empty CONTAINS "
1878 "section") == FAILURE
))
1881 /* ST_END_TYPE is accepted by parse_derived after return. */
1885 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1887 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1895 gfc_error ("PRIVATE statement at %C must precede procedure"
1903 gfc_error ("Duplicate PRIVATE statement at %C");
1907 accept_statement (ST_PRIVATE
);
1908 gfc_typebound_default_access
= ACCESS_PRIVATE
;
1909 seen_private
= true;
1913 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1918 gfc_error ("Already inside a CONTAINS block at %C");
1923 unexpected_statement (st
);
1929 gcc_assert (gfc_current_state () == COMP_DERIVED
);
1935 /* Parse a derived type. */
1938 parse_derived (void)
1940 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1943 gfc_symbol
*derived_sym
= NULL
;
1949 accept_statement (ST_DERIVED_DECL
);
1950 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1952 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1959 while (compiling_type
)
1961 st
= next_statement ();
1969 accept_statement (st
);
1974 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
1983 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
1984 "definition at %C without components")
1988 accept_statement (ST_END_TYPE
);
1992 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1994 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2002 gfc_error ("PRIVATE statement at %C must precede "
2003 "structure components");
2010 gfc_error ("Duplicate PRIVATE statement at %C");
2014 s
.sym
->component_access
= ACCESS_PRIVATE
;
2016 accept_statement (ST_PRIVATE
);
2023 gfc_error ("SEQUENCE statement at %C must precede "
2024 "structure components");
2029 if (gfc_current_block ()->attr
.sequence
)
2030 gfc_warning ("SEQUENCE attribute at %C already specified in "
2035 gfc_error ("Duplicate SEQUENCE statement at %C");
2040 gfc_add_sequence (&gfc_current_block ()->attr
,
2041 gfc_current_block ()->name
, NULL
);
2045 if (gfc_notify_std (GFC_STD_F2003
,
2046 "Fortran 2003: CONTAINS block in derived type"
2047 " definition at %C") == FAILURE
)
2050 accept_statement (ST_CONTAINS
);
2051 if (parse_derived_contains ())
2056 unexpected_statement (st
);
2061 /* need to verify that all fields of the derived type are
2062 * interoperable with C if the type is declared to be bind(c)
2064 derived_sym
= gfc_current_block();
2066 sym
= gfc_current_block ();
2067 for (c
= sym
->components
; c
; c
= c
->next
)
2069 /* Look for allocatable components. */
2070 if (c
->attr
.allocatable
2071 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.alloc_comp
))
2072 sym
->attr
.alloc_comp
= 1;
2074 /* Look for pointer components. */
2076 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2077 sym
->attr
.pointer_comp
= 1;
2079 /* Look for procedure pointer components. */
2080 if (c
->attr
.proc_pointer
2081 || (c
->ts
.type
== BT_DERIVED
2082 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2083 sym
->attr
.proc_pointer_comp
= 1;
2085 /* Look for private components. */
2086 if (sym
->component_access
== ACCESS_PRIVATE
2087 || c
->attr
.access
== ACCESS_PRIVATE
2088 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2089 sym
->attr
.private_comp
= 1;
2092 if (!seen_component
)
2093 sym
->attr
.zero_comp
= 1;
2099 /* Parse an ENUM. */
2108 int seen_enumerator
= 0;
2112 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2116 while (compiling_enum
)
2118 st
= next_statement ();
2126 seen_enumerator
= 1;
2127 accept_statement (st
);
2132 if (!seen_enumerator
)
2134 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2137 accept_statement (st
);
2141 gfc_free_enum_history ();
2142 unexpected_statement (st
);
2150 /* Parse an interface. We must be able to deal with the possibility
2151 of recursive interfaces. The parse_spec() subroutine is mutually
2152 recursive with parse_interface(). */
2154 static gfc_statement
parse_spec (gfc_statement
);
2157 parse_interface (void)
2159 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2160 gfc_symbol
*prog_unit
, *sym
;
2161 gfc_interface_info save
;
2162 gfc_state_data s1
, s2
;
2166 accept_statement (ST_INTERFACE
);
2168 current_interface
.ns
= gfc_current_ns
;
2169 save
= current_interface
;
2171 sym
= (current_interface
.type
== INTERFACE_GENERIC
2172 || current_interface
.type
== INTERFACE_USER_OP
)
2173 ? gfc_new_block
: NULL
;
2175 push_state (&s1
, COMP_INTERFACE
, sym
);
2176 current_state
= COMP_NONE
;
2179 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2181 st
= next_statement ();
2189 if (st
== ST_SUBROUTINE
)
2190 new_state
= COMP_SUBROUTINE
;
2191 else if (st
== ST_FUNCTION
)
2192 new_state
= COMP_FUNCTION
;
2193 if (gfc_new_block
->attr
.pointer
)
2195 gfc_new_block
->attr
.pointer
= 0;
2196 gfc_new_block
->attr
.proc_pointer
= 1;
2198 if (gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2199 gfc_new_block
->formal
, NULL
) == FAILURE
)
2201 reject_statement ();
2202 gfc_free_namespace (gfc_current_ns
);
2208 case ST_MODULE_PROC
: /* The module procedure matcher makes
2209 sure the context is correct. */
2210 accept_statement (st
);
2211 gfc_free_namespace (gfc_current_ns
);
2214 case ST_END_INTERFACE
:
2215 gfc_free_namespace (gfc_current_ns
);
2216 gfc_current_ns
= current_interface
.ns
;
2220 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2221 gfc_ascii_statement (st
));
2222 reject_statement ();
2223 gfc_free_namespace (gfc_current_ns
);
2228 /* Make sure that a generic interface has only subroutines or
2229 functions and that the generic name has the right attribute. */
2230 if (current_interface
.type
== INTERFACE_GENERIC
)
2232 if (current_state
== COMP_NONE
)
2234 if (new_state
== COMP_FUNCTION
)
2235 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2236 else if (new_state
== COMP_SUBROUTINE
)
2237 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2239 current_state
= new_state
;
2243 if (new_state
!= current_state
)
2245 if (new_state
== COMP_SUBROUTINE
)
2246 gfc_error ("SUBROUTINE at %C does not belong in a "
2247 "generic function interface");
2249 if (new_state
== COMP_FUNCTION
)
2250 gfc_error ("FUNCTION at %C does not belong in a "
2251 "generic subroutine interface");
2256 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2258 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2259 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2260 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2261 "cannot be the same as an intrinsic type",
2262 gfc_new_block
->name
);
2265 push_state (&s2
, new_state
, gfc_new_block
);
2266 accept_statement (st
);
2267 prog_unit
= gfc_new_block
;
2268 prog_unit
->formal_ns
= gfc_current_ns
;
2269 proc_locus
= gfc_current_locus
;
2272 /* Read data declaration statements. */
2273 st
= parse_spec (ST_NONE
);
2275 /* Since the interface block does not permit an IMPLICIT statement,
2276 the default type for the function or the result must be taken
2277 from the formal namespace. */
2278 if (new_state
== COMP_FUNCTION
)
2280 if (prog_unit
->result
== prog_unit
2281 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2282 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2283 else if (prog_unit
->result
!= prog_unit
2284 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
2285 gfc_set_default_type (prog_unit
->result
, 1,
2286 prog_unit
->formal_ns
);
2289 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
2291 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2292 gfc_ascii_statement (st
));
2293 reject_statement ();
2297 /* Add EXTERNAL attribute to function or subroutine. */
2298 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
2299 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
2301 current_interface
= save
;
2302 gfc_add_interface (prog_unit
);
2305 if (current_interface
.ns
2306 && current_interface
.ns
->proc_name
2307 && strcmp (current_interface
.ns
->proc_name
->name
,
2308 prog_unit
->name
) == 0)
2309 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2310 "enclosing procedure", prog_unit
->name
, &proc_locus
);
2319 /* Associate function characteristics by going back to the function
2320 declaration and rematching the prefix. */
2323 match_deferred_characteristics (gfc_typespec
* ts
)
2326 match m
= MATCH_ERROR
;
2327 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2329 loc
= gfc_current_locus
;
2331 gfc_current_locus
= gfc_current_block ()->declared_at
;
2334 gfc_buffer_error (1);
2335 m
= gfc_match_prefix (ts
);
2336 gfc_buffer_error (0);
2338 if (ts
->type
== BT_DERIVED
)
2342 if (!ts
->u
.derived
|| !ts
->u
.derived
->components
)
2346 /* Only permit one go at the characteristic association. */
2350 /* Set the function locus correctly. If we have not found the
2351 function name, there is an error. */
2353 && gfc_match ("function% %n", name
) == MATCH_YES
2354 && strcmp (name
, gfc_current_block ()->name
) == 0)
2356 gfc_current_block ()->declared_at
= gfc_current_locus
;
2357 gfc_commit_symbols ();
2362 gfc_current_locus
=loc
;
2367 /* Check specification-expressions in the function result of the currently
2368 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2369 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2370 scope are not yet parsed so this has to be delayed up to parse_spec. */
2373 check_function_result_typed (void)
2375 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
2377 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
2378 gcc_assert (ts
->type
!= BT_UNKNOWN
);
2380 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2381 /* TODO: Extend when KIND type parameters are implemented. */
2382 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
2383 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
2387 /* Parse a set of specification statements. Returns the statement
2388 that doesn't fit. */
2390 static gfc_statement
2391 parse_spec (gfc_statement st
)
2394 bool function_result_typed
= false;
2395 bool bad_characteristic
= false;
2398 verify_st_order (&ss
, ST_NONE
, false);
2400 st
= next_statement ();
2402 /* If we are not inside a function or don't have a result specified so far,
2403 do nothing special about it. */
2404 if (gfc_current_state () != COMP_FUNCTION
)
2405 function_result_typed
= true;
2408 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
2411 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
2412 function_result_typed
= true;
2417 /* If we're inside a BLOCK construct, some statements are disallowed.
2418 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2419 or VALUE are also disallowed, but they don't have a particular ST_*
2420 key so we have to check for them individually in their matcher routine. */
2421 if (gfc_current_state () == COMP_BLOCK
)
2425 case ST_IMPLICIT_NONE
:
2428 case ST_EQUIVALENCE
:
2429 case ST_STATEMENT_FUNCTION
:
2430 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2431 gfc_ascii_statement (st
));
2438 /* If we find a statement that can not be followed by an IMPLICIT statement
2439 (and thus we can expect to see none any further), type the function result
2440 if it has not yet been typed. Be careful not to give the END statement
2441 to verify_st_order! */
2442 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
2444 bool verify_now
= false;
2446 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
2451 verify_st_order (&dummyss
, ST_NONE
, false);
2452 verify_st_order (&dummyss
, st
, false);
2454 if (verify_st_order (&dummyss
, ST_IMPLICIT
, true) == FAILURE
)
2460 check_function_result_typed ();
2461 function_result_typed
= true;
2470 case ST_IMPLICIT_NONE
:
2472 if (!function_result_typed
)
2474 check_function_result_typed ();
2475 function_result_typed
= true;
2481 case ST_DATA
: /* Not allowed in interfaces */
2482 if (gfc_current_state () == COMP_INTERFACE
)
2492 case ST_DERIVED_DECL
:
2495 if (verify_st_order (&ss
, st
, false) == FAILURE
)
2497 reject_statement ();
2498 st
= next_statement ();
2508 case ST_DERIVED_DECL
:
2514 if (gfc_current_state () != COMP_MODULE
)
2516 gfc_error ("%s statement must appear in a MODULE",
2517 gfc_ascii_statement (st
));
2521 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
2523 gfc_error ("%s statement at %C follows another accessibility "
2524 "specification", gfc_ascii_statement (st
));
2528 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
2529 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2533 case ST_STATEMENT_FUNCTION
:
2534 if (gfc_current_state () == COMP_MODULE
)
2536 unexpected_statement (st
);
2544 accept_statement (st
);
2545 st
= next_statement ();
2549 accept_statement (st
);
2551 st
= next_statement ();
2554 case ST_GET_FCN_CHARACTERISTICS
:
2555 /* This statement triggers the association of a function's result
2557 ts
= &gfc_current_block ()->result
->ts
;
2558 if (match_deferred_characteristics (ts
) != MATCH_YES
)
2559 bad_characteristic
= true;
2561 st
= next_statement ();
2568 /* If match_deferred_characteristics failed, then there is an error. */
2569 if (bad_characteristic
)
2571 ts
= &gfc_current_block ()->result
->ts
;
2572 if (ts
->type
!= BT_DERIVED
)
2573 gfc_error ("Bad kind expression for function '%s' at %L",
2574 gfc_current_block ()->name
,
2575 &gfc_current_block ()->declared_at
);
2577 gfc_error ("The type for function '%s' at %L is not accessible",
2578 gfc_current_block ()->name
,
2579 &gfc_current_block ()->declared_at
);
2581 gfc_current_block ()->ts
.kind
= 0;
2582 /* Keep the derived type; if it's bad, it will be discovered later. */
2583 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
2584 ts
->type
= BT_UNKNOWN
;
2591 /* Parse a WHERE block, (not a simple WHERE statement). */
2594 parse_where_block (void)
2596 int seen_empty_else
;
2601 accept_statement (ST_WHERE_BLOCK
);
2602 top
= gfc_state_stack
->tail
;
2604 push_state (&s
, COMP_WHERE
, gfc_new_block
);
2606 d
= add_statement ();
2607 d
->expr1
= top
->expr1
;
2613 seen_empty_else
= 0;
2617 st
= next_statement ();
2623 case ST_WHERE_BLOCK
:
2624 parse_where_block ();
2629 accept_statement (st
);
2633 if (seen_empty_else
)
2635 gfc_error ("ELSEWHERE statement at %C follows previous "
2636 "unmasked ELSEWHERE");
2640 if (new_st
.expr1
== NULL
)
2641 seen_empty_else
= 1;
2643 d
= new_level (gfc_state_stack
->head
);
2645 d
->expr1
= new_st
.expr1
;
2647 accept_statement (st
);
2652 accept_statement (st
);
2656 gfc_error ("Unexpected %s statement in WHERE block at %C",
2657 gfc_ascii_statement (st
));
2658 reject_statement ();
2662 while (st
!= ST_END_WHERE
);
2668 /* Parse a FORALL block (not a simple FORALL statement). */
2671 parse_forall_block (void)
2677 accept_statement (ST_FORALL_BLOCK
);
2678 top
= gfc_state_stack
->tail
;
2680 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2682 d
= add_statement ();
2683 d
->op
= EXEC_FORALL
;
2688 st
= next_statement ();
2693 case ST_POINTER_ASSIGNMENT
:
2696 accept_statement (st
);
2699 case ST_WHERE_BLOCK
:
2700 parse_where_block ();
2703 case ST_FORALL_BLOCK
:
2704 parse_forall_block ();
2708 accept_statement (st
);
2715 gfc_error ("Unexpected %s statement in FORALL block at %C",
2716 gfc_ascii_statement (st
));
2718 reject_statement ();
2722 while (st
!= ST_END_FORALL
);
2728 static gfc_statement
parse_executable (gfc_statement
);
2730 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2733 parse_if_block (void)
2742 accept_statement (ST_IF_BLOCK
);
2744 top
= gfc_state_stack
->tail
;
2745 push_state (&s
, COMP_IF
, gfc_new_block
);
2747 new_st
.op
= EXEC_IF
;
2748 d
= add_statement ();
2750 d
->expr1
= top
->expr1
;
2756 st
= parse_executable (ST_NONE
);
2766 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2767 "statement at %L", &else_locus
);
2769 reject_statement ();
2773 d
= new_level (gfc_state_stack
->head
);
2775 d
->expr1
= new_st
.expr1
;
2777 accept_statement (st
);
2784 gfc_error ("Duplicate ELSE statements at %L and %C",
2786 reject_statement ();
2791 else_locus
= gfc_current_locus
;
2793 d
= new_level (gfc_state_stack
->head
);
2796 accept_statement (st
);
2804 unexpected_statement (st
);
2808 while (st
!= ST_ENDIF
);
2811 accept_statement (st
);
2815 /* Parse a SELECT block. */
2818 parse_select_block (void)
2824 accept_statement (ST_SELECT_CASE
);
2826 cp
= gfc_state_stack
->tail
;
2827 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2829 /* Make sure that the next statement is a CASE or END SELECT. */
2832 st
= next_statement ();
2835 if (st
== ST_END_SELECT
)
2837 /* Empty SELECT CASE is OK. */
2838 accept_statement (st
);
2845 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2848 reject_statement ();
2851 /* At this point, we're got a nonempty select block. */
2852 cp
= new_level (cp
);
2855 accept_statement (st
);
2859 st
= parse_executable (ST_NONE
);
2866 cp
= new_level (gfc_state_stack
->head
);
2868 gfc_clear_new_st ();
2870 accept_statement (st
);
2876 /* Can't have an executable statement because of
2877 parse_executable(). */
2879 unexpected_statement (st
);
2883 while (st
!= ST_END_SELECT
);
2886 accept_statement (st
);
2890 /* Pop the current selector from the SELECT TYPE stack. */
2893 select_type_pop (void)
2895 gfc_select_type_stack
*old
= select_type_stack
;
2896 select_type_stack
= old
->prev
;
2901 /* Parse a SELECT TYPE construct (F03:R821). */
2904 parse_select_type_block (void)
2910 accept_statement (ST_SELECT_TYPE
);
2912 cp
= gfc_state_stack
->tail
;
2913 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
2915 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2919 st
= next_statement ();
2922 if (st
== ST_END_SELECT
)
2923 /* Empty SELECT CASE is OK. */
2925 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
2928 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2929 "following SELECT TYPE at %C");
2931 reject_statement ();
2934 /* At this point, we're got a nonempty select block. */
2935 cp
= new_level (cp
);
2938 accept_statement (st
);
2942 st
= parse_executable (ST_NONE
);
2950 cp
= new_level (gfc_state_stack
->head
);
2952 gfc_clear_new_st ();
2954 accept_statement (st
);
2960 /* Can't have an executable statement because of
2961 parse_executable(). */
2963 unexpected_statement (st
);
2967 while (st
!= ST_END_SELECT
);
2971 accept_statement (st
);
2972 gfc_current_ns
= gfc_current_ns
->parent
;
2977 /* Given a symbol, make sure it is not an iteration variable for a DO
2978 statement. This subroutine is called when the symbol is seen in a
2979 context that causes it to become redefined. If the symbol is an
2980 iterator, we generate an error message and return nonzero. */
2983 gfc_check_do_variable (gfc_symtree
*st
)
2987 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
2988 if (s
->do_variable
== st
)
2990 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2991 "loop beginning at %L", st
->name
, &s
->head
->loc
);
2999 /* Checks to see if the current statement label closes an enddo.
3000 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3001 an error) if it incorrectly closes an ENDDO. */
3004 check_do_closure (void)
3008 if (gfc_statement_label
== NULL
)
3011 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3012 if (p
->state
== COMP_DO
)
3016 return 0; /* No loops to close */
3018 if (p
->ext
.end_do_label
== gfc_statement_label
)
3020 if (p
== gfc_state_stack
)
3023 gfc_error ("End of nonblock DO statement at %C is within another block");
3027 /* At this point, the label doesn't terminate the innermost loop.
3028 Make sure it doesn't terminate another one. */
3029 for (; p
; p
= p
->previous
)
3030 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
3032 gfc_error ("End of nonblock DO statement at %C is interwoven "
3033 "with another DO loop");
3041 /* Parse a series of contained program units. */
3043 static void parse_progunit (gfc_statement
);
3046 /* Set up the local namespace for a BLOCK construct. */
3049 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3051 gfc_namespace
* my_ns
;
3053 my_ns
= gfc_get_namespace (parent_ns
, 1);
3054 my_ns
->construct_entities
= 1;
3056 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3057 code generation (so it must not be NULL).
3058 We set its recursive argument if our container procedure is recursive, so
3059 that local variables are accordingly placed on the stack when it
3060 will be necessary. */
3062 my_ns
->proc_name
= gfc_new_block
;
3067 gfc_get_symbol ("block@", my_ns
, &my_ns
->proc_name
);
3068 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3069 my_ns
->proc_name
->name
, NULL
);
3070 gcc_assert (t
== SUCCESS
);
3073 if (parent_ns
->proc_name
)
3074 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3080 /* Parse a BLOCK construct. */
3083 parse_block_construct (void)
3085 gfc_namespace
* my_ns
;
3088 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: BLOCK construct at %C");
3090 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3092 new_st
.op
= EXEC_BLOCK
;
3093 new_st
.ext
.ns
= my_ns
;
3094 accept_statement (ST_BLOCK
);
3096 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3097 gfc_current_ns
= my_ns
;
3099 parse_progunit (ST_NONE
);
3101 gfc_current_ns
= gfc_current_ns
->parent
;
3106 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3107 handled inside of parse_executable(), because they aren't really
3111 parse_do_block (void)
3118 s
.ext
.end_do_label
= new_st
.label1
;
3120 if (new_st
.ext
.iterator
!= NULL
)
3121 stree
= new_st
.ext
.iterator
->var
->symtree
;
3125 accept_statement (ST_DO
);
3127 top
= gfc_state_stack
->tail
;
3128 push_state (&s
, COMP_DO
, gfc_new_block
);
3130 s
.do_variable
= stree
;
3132 top
->block
= new_level (top
);
3133 top
->block
->op
= EXEC_DO
;
3136 st
= parse_executable (ST_NONE
);
3144 if (s
.ext
.end_do_label
!= NULL
3145 && s
.ext
.end_do_label
!= gfc_statement_label
)
3146 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3149 if (gfc_statement_label
!= NULL
)
3151 new_st
.op
= EXEC_NOP
;
3156 case ST_IMPLIED_ENDDO
:
3157 /* If the do-stmt of this DO construct has a do-construct-name,
3158 the corresponding end-do must be an end-do-stmt (with a matching
3159 name, but in that case we must have seen ST_ENDDO first).
3160 We only complain about this in pedantic mode. */
3161 if (gfc_current_block () != NULL
)
3162 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3163 &gfc_current_block()->declared_at
);
3168 unexpected_statement (st
);
3173 accept_statement (st
);
3177 /* Parse the statements of OpenMP do/parallel do. */
3179 static gfc_statement
3180 parse_omp_do (gfc_statement omp_st
)
3186 accept_statement (omp_st
);
3188 cp
= gfc_state_stack
->tail
;
3189 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3190 np
= new_level (cp
);
3196 st
= next_statement ();
3199 else if (st
== ST_DO
)
3202 unexpected_statement (st
);
3206 if (gfc_statement_label
!= NULL
3207 && gfc_state_stack
->previous
!= NULL
3208 && gfc_state_stack
->previous
->state
== COMP_DO
3209 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
3217 there should be no !$OMP END DO. */
3219 return ST_IMPLIED_ENDDO
;
3222 check_do_closure ();
3225 st
= next_statement ();
3226 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
3228 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
3229 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3231 gcc_assert (new_st
.op
== EXEC_NOP
);
3232 gfc_clear_new_st ();
3233 gfc_commit_symbols ();
3234 gfc_warning_check ();
3235 st
= next_statement ();
3241 /* Parse the statements of OpenMP atomic directive. */
3244 parse_omp_atomic (void)
3250 accept_statement (ST_OMP_ATOMIC
);
3252 cp
= gfc_state_stack
->tail
;
3253 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3254 np
= new_level (cp
);
3260 st
= next_statement ();
3263 else if (st
== ST_ASSIGNMENT
)
3266 unexpected_statement (st
);
3269 accept_statement (st
);
3275 /* Parse the statements of an OpenMP structured block. */
3278 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
3280 gfc_statement st
, omp_end_st
;
3284 accept_statement (omp_st
);
3286 cp
= gfc_state_stack
->tail
;
3287 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3288 np
= new_level (cp
);
3294 case ST_OMP_PARALLEL
:
3295 omp_end_st
= ST_OMP_END_PARALLEL
;
3297 case ST_OMP_PARALLEL_SECTIONS
:
3298 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
3300 case ST_OMP_SECTIONS
:
3301 omp_end_st
= ST_OMP_END_SECTIONS
;
3303 case ST_OMP_ORDERED
:
3304 omp_end_st
= ST_OMP_END_ORDERED
;
3306 case ST_OMP_CRITICAL
:
3307 omp_end_st
= ST_OMP_END_CRITICAL
;
3310 omp_end_st
= ST_OMP_END_MASTER
;
3313 omp_end_st
= ST_OMP_END_SINGLE
;
3316 omp_end_st
= ST_OMP_END_TASK
;
3318 case ST_OMP_WORKSHARE
:
3319 omp_end_st
= ST_OMP_END_WORKSHARE
;
3321 case ST_OMP_PARALLEL_WORKSHARE
:
3322 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
3330 if (workshare_stmts_only
)
3332 /* Inside of !$omp workshare, only
3335 where statements and constructs
3336 forall statements and constructs
3340 are allowed. For !$omp critical these
3341 restrictions apply recursively. */
3344 st
= next_statement ();
3355 accept_statement (st
);
3358 case ST_WHERE_BLOCK
:
3359 parse_where_block ();
3362 case ST_FORALL_BLOCK
:
3363 parse_forall_block ();
3366 case ST_OMP_PARALLEL
:
3367 case ST_OMP_PARALLEL_SECTIONS
:
3368 parse_omp_structured_block (st
, false);
3371 case ST_OMP_PARALLEL_WORKSHARE
:
3372 case ST_OMP_CRITICAL
:
3373 parse_omp_structured_block (st
, true);
3376 case ST_OMP_PARALLEL_DO
:
3377 st
= parse_omp_do (st
);
3381 parse_omp_atomic ();
3392 st
= next_statement ();
3396 st
= parse_executable (ST_NONE
);
3399 else if (st
== ST_OMP_SECTION
3400 && (omp_st
== ST_OMP_SECTIONS
3401 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
3403 np
= new_level (np
);
3407 else if (st
!= omp_end_st
)
3408 unexpected_statement (st
);
3410 while (st
!= omp_end_st
);
3414 case EXEC_OMP_END_NOWAIT
:
3415 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3417 case EXEC_OMP_CRITICAL
:
3418 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
3419 || (new_st
.ext
.omp_name
!= NULL
3420 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
3421 gfc_error ("Name after !$omp critical and !$omp end critical does "
3423 gfc_free (CONST_CAST (char *, new_st
.ext
.omp_name
));
3425 case EXEC_OMP_END_SINGLE
:
3426 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
3427 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
3428 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
3429 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
3437 gfc_clear_new_st ();
3438 gfc_commit_symbols ();
3439 gfc_warning_check ();
3444 /* Accept a series of executable statements. We return the first
3445 statement that doesn't fit to the caller. Any block statements are
3446 passed on to the correct handler, which usually passes the buck
3449 static gfc_statement
3450 parse_executable (gfc_statement st
)
3455 st
= next_statement ();
3459 close_flag
= check_do_closure ();
3464 case ST_END_PROGRAM
:
3467 case ST_END_FUNCTION
:
3471 case ST_END_SUBROUTINE
:
3476 case ST_SELECT_CASE
:
3477 gfc_error ("%s statement at %C cannot terminate a non-block "
3478 "DO loop", gfc_ascii_statement (st
));
3494 accept_statement (st
);
3495 if (close_flag
== 1)
3496 return ST_IMPLIED_ENDDO
;
3500 parse_block_construct ();
3507 case ST_SELECT_CASE
:
3508 parse_select_block ();
3511 case ST_SELECT_TYPE
:
3512 parse_select_type_block();
3517 if (check_do_closure () == 1)
3518 return ST_IMPLIED_ENDDO
;
3521 case ST_WHERE_BLOCK
:
3522 parse_where_block ();
3525 case ST_FORALL_BLOCK
:
3526 parse_forall_block ();
3529 case ST_OMP_PARALLEL
:
3530 case ST_OMP_PARALLEL_SECTIONS
:
3531 case ST_OMP_SECTIONS
:
3532 case ST_OMP_ORDERED
:
3533 case ST_OMP_CRITICAL
:
3537 parse_omp_structured_block (st
, false);
3540 case ST_OMP_WORKSHARE
:
3541 case ST_OMP_PARALLEL_WORKSHARE
:
3542 parse_omp_structured_block (st
, true);
3546 case ST_OMP_PARALLEL_DO
:
3547 st
= parse_omp_do (st
);
3548 if (st
== ST_IMPLIED_ENDDO
)
3553 parse_omp_atomic ();
3560 st
= next_statement ();
3565 /* Fix the symbols for sibling functions. These are incorrectly added to
3566 the child namespace as the parser didn't know about this procedure. */
3569 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
3573 gfc_symbol
*old_sym
;
3575 sym
->attr
.referenced
= 1;
3576 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
3578 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
3580 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
3581 goto fixup_contained
;
3583 old_sym
= st
->n
.sym
;
3584 if (old_sym
->ns
== ns
3585 && !old_sym
->attr
.contained
3587 /* By 14.6.1.3, host association should be excluded
3588 for the following. */
3589 && !(old_sym
->attr
.external
3590 || (old_sym
->ts
.type
!= BT_UNKNOWN
3591 && !old_sym
->attr
.implicit_type
)
3592 || old_sym
->attr
.flavor
== FL_PARAMETER
3593 || old_sym
->attr
.in_common
3594 || old_sym
->attr
.in_equivalence
3595 || old_sym
->attr
.data
3596 || old_sym
->attr
.dummy
3597 || old_sym
->attr
.result
3598 || old_sym
->attr
.dimension
3599 || old_sym
->attr
.allocatable
3600 || old_sym
->attr
.intrinsic
3601 || old_sym
->attr
.generic
3602 || old_sym
->attr
.flavor
== FL_NAMELIST
3603 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
3605 /* Replace it with the symbol from the parent namespace. */
3609 /* Free the old (local) symbol. */
3611 if (old_sym
->refs
== 0)
3612 gfc_free_symbol (old_sym
);
3616 /* Do the same for any contained procedures. */
3617 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
3622 parse_contained (int module
)
3624 gfc_namespace
*ns
, *parent_ns
, *tmp
;
3625 gfc_state_data s1
, s2
;
3629 int contains_statements
= 0;
3632 push_state (&s1
, COMP_CONTAINS
, NULL
);
3633 parent_ns
= gfc_current_ns
;
3637 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
3639 gfc_current_ns
->sibling
= parent_ns
->contained
;
3640 parent_ns
->contained
= gfc_current_ns
;
3643 /* Process the next available statement. We come here if we got an error
3644 and rejected the last statement. */
3645 st
= next_statement ();
3654 contains_statements
= 1;
3655 accept_statement (st
);
3658 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
3661 /* For internal procedures, create/update the symbol in the
3662 parent namespace. */
3666 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
3667 gfc_error ("Contained procedure '%s' at %C is already "
3668 "ambiguous", gfc_new_block
->name
);
3671 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
3672 &gfc_new_block
->declared_at
) ==
3675 if (st
== ST_FUNCTION
)
3676 gfc_add_function (&sym
->attr
, sym
->name
,
3677 &gfc_new_block
->declared_at
);
3679 gfc_add_subroutine (&sym
->attr
, sym
->name
,
3680 &gfc_new_block
->declared_at
);
3684 gfc_commit_symbols ();
3687 sym
= gfc_new_block
;
3689 /* Mark this as a contained function, so it isn't replaced
3690 by other module functions. */
3691 sym
->attr
.contained
= 1;
3692 sym
->attr
.referenced
= 1;
3694 parse_progunit (ST_NONE
);
3696 /* Fix up any sibling functions that refer to this one. */
3697 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
3698 /* Or refer to any of its alternate entry points. */
3699 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
3700 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
3702 gfc_current_ns
->code
= s2
.head
;
3703 gfc_current_ns
= parent_ns
;
3708 /* These statements are associated with the end of the host unit. */
3709 case ST_END_FUNCTION
:
3711 case ST_END_PROGRAM
:
3712 case ST_END_SUBROUTINE
:
3713 accept_statement (st
);
3717 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3718 gfc_ascii_statement (st
));
3719 reject_statement ();
3725 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
3726 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
3728 /* The first namespace in the list is guaranteed to not have
3729 anything (worthwhile) in it. */
3730 tmp
= gfc_current_ns
;
3731 gfc_current_ns
= parent_ns
;
3732 if (seen_error
&& tmp
->refs
> 1)
3733 gfc_free_namespace (tmp
);
3735 ns
= gfc_current_ns
->contained
;
3736 gfc_current_ns
->contained
= ns
->sibling
;
3737 gfc_free_namespace (ns
);
3740 if (!contains_statements
)
3741 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: CONTAINS statement without "
3742 "FUNCTION or SUBROUTINE statement at %C");
3746 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
3749 parse_progunit (gfc_statement st
)
3754 st
= parse_spec (st
);
3761 /* This is not allowed within BLOCK! */
3762 if (gfc_current_state () != COMP_BLOCK
)
3767 accept_statement (st
);
3774 if (gfc_current_state () == COMP_FUNCTION
)
3775 gfc_check_function_type (gfc_current_ns
);
3780 st
= parse_executable (st
);
3788 /* This is not allowed within BLOCK! */
3789 if (gfc_current_state () != COMP_BLOCK
)
3794 accept_statement (st
);
3801 unexpected_statement (st
);
3802 reject_statement ();
3803 st
= next_statement ();
3809 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3810 if (p
->state
== COMP_CONTAINS
)
3813 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
3818 gfc_error ("CONTAINS statement at %C is already in a contained "
3820 st
= next_statement ();
3824 parse_contained (0);
3827 gfc_current_ns
->code
= gfc_state_stack
->head
;
3831 /* Come here to complain about a global symbol already in use as
3835 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
3840 where
= &gfc_current_locus
;
3850 case GSYM_SUBROUTINE
:
3851 name
= "SUBROUTINE";
3856 case GSYM_BLOCK_DATA
:
3857 name
= "BLOCK DATA";
3863 gfc_internal_error ("gfc_global_used(): Bad type");
3867 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3868 sym
->name
, where
, name
, &sym
->where
);
3872 /* Parse a block data program unit. */
3875 parse_block_data (void)
3878 static locus blank_locus
;
3879 static int blank_block
=0;
3882 gfc_current_ns
->proc_name
= gfc_new_block
;
3883 gfc_current_ns
->is_block_data
= 1;
3885 if (gfc_new_block
== NULL
)
3888 gfc_error ("Blank BLOCK DATA at %C conflicts with "
3889 "prior BLOCK DATA at %L", &blank_locus
);
3893 blank_locus
= gfc_current_locus
;
3898 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3900 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
3901 gfc_global_used(s
, NULL
);
3904 s
->type
= GSYM_BLOCK_DATA
;
3905 s
->where
= gfc_current_locus
;
3910 st
= parse_spec (ST_NONE
);
3912 while (st
!= ST_END_BLOCK_DATA
)
3914 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3915 gfc_ascii_statement (st
));
3916 reject_statement ();
3917 st
= next_statement ();
3922 /* Parse a module subprogram. */
3930 s
= gfc_get_gsymbol (gfc_new_block
->name
);
3931 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
3932 gfc_global_used(s
, NULL
);
3935 s
->type
= GSYM_MODULE
;
3936 s
->where
= gfc_current_locus
;
3940 st
= parse_spec (ST_NONE
);
3949 parse_contained (1);
3953 accept_statement (st
);
3957 gfc_error ("Unexpected %s statement in MODULE at %C",
3958 gfc_ascii_statement (st
));
3960 reject_statement ();
3961 st
= next_statement ();
3965 s
->ns
= gfc_current_ns
;
3969 /* Add a procedure name to the global symbol table. */
3972 add_global_procedure (int sub
)
3976 s
= gfc_get_gsymbol(gfc_new_block
->name
);
3979 || (s
->type
!= GSYM_UNKNOWN
3980 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
3981 gfc_global_used(s
, NULL
);
3984 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
3985 s
->where
= gfc_current_locus
;
3987 s
->ns
= gfc_current_ns
;
3992 /* Add a program to the global symbol table. */
3995 add_global_program (void)
3999 if (gfc_new_block
== NULL
)
4001 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4003 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
4004 gfc_global_used(s
, NULL
);
4007 s
->type
= GSYM_PROGRAM
;
4008 s
->where
= gfc_current_locus
;
4010 s
->ns
= gfc_current_ns
;
4015 /* Resolve all the program units when whole file scope option
4018 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4020 gfc_free_dt_list ();
4021 gfc_current_ns
= gfc_global_ns_list
;
4022 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4024 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4025 gfc_resolve (gfc_current_ns
);
4026 gfc_current_ns
->derived_types
= gfc_derived_types
;
4027 gfc_derived_types
= NULL
;
4033 clean_up_modules (gfc_gsymbol
*gsym
)
4038 clean_up_modules (gsym
->left
);
4039 clean_up_modules (gsym
->right
);
4041 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
4044 gfc_current_ns
= gsym
->ns
;
4045 gfc_derived_types
= gfc_current_ns
->derived_types
;
4052 /* Translate all the program units when whole file scope option
4053 is active. This could be in a different order to resolution if
4054 there are forward references in the file. */
4056 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4060 gfc_current_ns
= gfc_global_ns_list
;
4061 gfc_get_errors (NULL
, &errors
);
4063 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4065 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4066 gfc_derived_types
= gfc_current_ns
->derived_types
;
4067 gfc_generate_code (gfc_current_ns
);
4068 gfc_current_ns
->translated
= 1;
4071 /* Clean up all the namespaces after translation. */
4072 gfc_current_ns
= gfc_global_ns_list
;
4073 for (;gfc_current_ns
;)
4075 gfc_namespace
*ns
= gfc_current_ns
->sibling
;
4076 gfc_derived_types
= gfc_current_ns
->derived_types
;
4078 gfc_current_ns
= ns
;
4081 clean_up_modules (gfc_gsym_root
);
4085 /* Top level parser. */
4088 gfc_parse_file (void)
4090 int seen_program
, errors_before
, errors
;
4091 gfc_state_data top
, s
;
4094 gfc_namespace
*next
;
4096 gfc_start_source_files ();
4098 top
.state
= COMP_NONE
;
4100 top
.previous
= NULL
;
4101 top
.head
= top
.tail
= NULL
;
4102 top
.do_variable
= NULL
;
4104 gfc_state_stack
= &top
;
4106 gfc_clear_new_st ();
4108 gfc_statement_label
= NULL
;
4110 if (setjmp (eof_buf
))
4111 return FAILURE
; /* Come here on unexpected EOF */
4113 /* Prepare the global namespace that will contain the
4115 gfc_global_ns_list
= next
= NULL
;
4119 /* Exit early for empty files. */
4125 st
= next_statement ();
4134 goto duplicate_main
;
4136 prog_locus
= gfc_current_locus
;
4138 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4139 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
4140 accept_statement (st
);
4141 add_global_program ();
4142 parse_progunit (ST_NONE
);
4143 if (gfc_option
.flag_whole_file
)
4148 add_global_procedure (1);
4149 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
4150 accept_statement (st
);
4151 parse_progunit (ST_NONE
);
4152 if (gfc_option
.flag_whole_file
)
4157 add_global_procedure (0);
4158 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
4159 accept_statement (st
);
4160 parse_progunit (ST_NONE
);
4161 if (gfc_option
.flag_whole_file
)
4166 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
4167 accept_statement (st
);
4168 parse_block_data ();
4172 push_state (&s
, COMP_MODULE
, gfc_new_block
);
4173 accept_statement (st
);
4175 gfc_get_errors (NULL
, &errors_before
);
4179 /* Anything else starts a nameless main program block. */
4182 goto duplicate_main
;
4184 prog_locus
= gfc_current_locus
;
4186 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4187 main_program_symbol (gfc_current_ns
, "MAIN__");
4188 parse_progunit (st
);
4189 if (gfc_option
.flag_whole_file
)
4194 /* Handle the non-program units. */
4195 gfc_current_ns
->code
= s
.head
;
4197 gfc_resolve (gfc_current_ns
);
4199 /* Dump the parse tree if requested. */
4200 if (gfc_option
.dump_parse_tree
)
4201 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4203 gfc_get_errors (NULL
, &errors
);
4204 if (s
.state
== COMP_MODULE
)
4206 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
4208 gfc_generate_module_code (gfc_current_ns
);
4210 if (!gfc_option
.flag_whole_file
)
4214 gfc_current_ns
->derived_types
= gfc_derived_types
;
4215 gfc_derived_types
= NULL
;
4216 gfc_current_ns
= NULL
;
4222 gfc_generate_code (gfc_current_ns
);
4230 /* The main program and non-contained procedures are put
4231 in the global namespace list, so that they can be processed
4232 later and all their interfaces resolved. */
4233 gfc_current_ns
->code
= s
.head
;
4235 next
->sibling
= gfc_current_ns
;
4237 gfc_global_ns_list
= gfc_current_ns
;
4239 next
= gfc_current_ns
;
4246 if (!gfc_option
.flag_whole_file
)
4249 /* Do the resolution. */
4250 resolve_all_program_units (gfc_global_ns_list
);
4252 /* Do the parse tree dump. */
4254 = gfc_option
.dump_parse_tree
? gfc_global_ns_list
: NULL
;
4256 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4258 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4259 fputs ("------------------------------------------\n\n", stdout
);
4262 /* Do the translation. */
4263 translate_all_program_units (gfc_global_ns_list
);
4267 gfc_end_source_files ();
4271 /* If we see a duplicate main program, shut down. If the second
4272 instance is an implied main program, i.e. data decls or executable
4273 statements, we're in for lots of errors. */
4274 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
4275 reject_statement ();