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 ()->result
->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
,
132 match ("allocatable", gfc_match_asynchronous
, ST_ATTR_DECL
);
133 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
137 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
141 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
142 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
146 match ("data", gfc_match_data
, ST_DATA
);
147 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
151 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
152 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
153 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
154 match ("external", gfc_match_external
, ST_ATTR_DECL
);
158 match ("format", gfc_match_format
, ST_FORMAT
);
165 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
166 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
167 match ("interface", gfc_match_interface
, ST_INTERFACE
);
168 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
169 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
176 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
180 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
184 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
185 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
186 if (gfc_match_private (&st
) == MATCH_YES
)
188 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
189 if (gfc_match_public (&st
) == MATCH_YES
)
191 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
198 match ("save", gfc_match_save
, ST_ATTR_DECL
);
202 match ("target", gfc_match_target
, ST_ATTR_DECL
);
203 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
210 match ("value", gfc_match_value
, ST_ATTR_DECL
);
211 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
218 /* This is not a specification statement. See if any of the matchers
219 has stored an error message of some sort. */
223 gfc_buffer_error (0);
224 gfc_current_locus
= old_locus
;
226 return ST_GET_FCN_CHARACTERISTICS
;
230 /* This is the primary 'decode_statement'. */
232 decode_statement (void)
239 gfc_enforce_clean_symbol_state ();
241 gfc_clear_error (); /* Clear any pending errors. */
242 gfc_clear_warning (); /* Clear any pending warnings. */
244 gfc_matching_function
= false;
246 if (gfc_match_eos () == MATCH_YES
)
249 if (gfc_current_state () == COMP_FUNCTION
250 && gfc_current_block ()->result
->ts
.kind
== -1)
251 return decode_specification_statement ();
253 old_locus
= gfc_current_locus
;
255 /* Try matching a data declaration or function declaration. The
256 input "REALFUNCTIONA(N)" can mean several things in different
257 contexts, so it (and its relatives) get special treatment. */
259 if (gfc_current_state () == COMP_NONE
260 || gfc_current_state () == COMP_INTERFACE
261 || gfc_current_state () == COMP_CONTAINS
)
263 gfc_matching_function
= true;
264 m
= gfc_match_function_decl ();
267 else if (m
== MATCH_ERROR
)
271 gfc_current_locus
= old_locus
;
273 gfc_matching_function
= false;
276 /* Match statements whose error messages are meant to be overwritten
277 by something better. */
279 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
280 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
281 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
283 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
284 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
286 /* Try to match a subroutine statement, which has the same optional
287 prefixes that functions can have. */
289 if (gfc_match_subroutine () == MATCH_YES
)
290 return ST_SUBROUTINE
;
292 gfc_current_locus
= old_locus
;
294 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
295 statements, which might begin with a block label. The match functions for
296 these statements are unusual in that their keyword is not seen before
297 the matcher is called. */
299 if (gfc_match_if (&st
) == MATCH_YES
)
302 gfc_current_locus
= old_locus
;
304 if (gfc_match_where (&st
) == MATCH_YES
)
307 gfc_current_locus
= old_locus
;
309 if (gfc_match_forall (&st
) == MATCH_YES
)
312 gfc_current_locus
= old_locus
;
314 match (NULL
, gfc_match_do
, ST_DO
);
315 match (NULL
, gfc_match_block
, ST_BLOCK
);
316 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
317 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
318 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
319 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
321 /* General statement matching: Instead of testing every possible
322 statement, we eliminate most possibilities by peeking at the
325 c
= gfc_peek_ascii_char ();
330 match ("abstract% interface", gfc_match_abstract_interface
,
332 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
333 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
334 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
335 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
339 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
340 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
341 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
345 match ("call", gfc_match_call
, ST_CALL
);
346 match ("close", gfc_match_close
, ST_CLOSE
);
347 match ("continue", gfc_match_continue
, ST_CONTINUE
);
348 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
349 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
350 match ("case", gfc_match_case
, ST_CASE
);
351 match ("common", gfc_match_common
, ST_COMMON
);
352 match ("contains", gfc_match_eos
, ST_CONTAINS
);
353 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
354 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
358 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
359 match ("data", gfc_match_data
, ST_DATA
);
360 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
364 match ("end file", gfc_match_endfile
, ST_END_FILE
);
365 match ("exit", gfc_match_exit
, ST_EXIT
);
366 match ("else", gfc_match_else
, ST_ELSE
);
367 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
368 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
369 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
370 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
372 if (gfc_match_end (&st
) == MATCH_YES
)
375 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
376 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
377 match ("external", gfc_match_external
, ST_ATTR_DECL
);
381 match ("final", gfc_match_final_decl
, ST_FINAL
);
382 match ("flush", gfc_match_flush
, ST_FLUSH
);
383 match ("format", gfc_match_format
, ST_FORMAT
);
387 match ("generic", gfc_match_generic
, ST_GENERIC
);
388 match ("go to", gfc_match_goto
, ST_GOTO
);
392 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
393 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
394 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
395 match ("import", gfc_match_import
, ST_IMPORT
);
396 match ("interface", gfc_match_interface
, ST_INTERFACE
);
397 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
398 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
402 match ("lock", gfc_match_lock
, ST_LOCK
);
406 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
407 match ("module", gfc_match_module
, ST_MODULE
);
411 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
412 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
416 match ("open", gfc_match_open
, ST_OPEN
);
417 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
421 match ("print", gfc_match_print
, ST_WRITE
);
422 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
423 match ("pause", gfc_match_pause
, ST_PAUSE
);
424 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
425 if (gfc_match_private (&st
) == MATCH_YES
)
427 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
428 match ("program", gfc_match_program
, ST_PROGRAM
);
429 if (gfc_match_public (&st
) == MATCH_YES
)
431 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
435 match ("read", gfc_match_read
, ST_READ
);
436 match ("return", gfc_match_return
, ST_RETURN
);
437 match ("rewind", gfc_match_rewind
, ST_REWIND
);
441 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
442 match ("stop", gfc_match_stop
, ST_STOP
);
443 match ("save", gfc_match_save
, ST_ATTR_DECL
);
444 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
445 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
446 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
450 match ("target", gfc_match_target
, ST_ATTR_DECL
);
451 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
452 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
456 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
457 match ("use", gfc_match_use
, ST_USE
);
461 match ("value", gfc_match_value
, ST_ATTR_DECL
);
462 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
466 match ("wait", gfc_match_wait
, ST_WAIT
);
467 match ("write", gfc_match_write
, ST_WRITE
);
471 /* All else has failed, so give up. See if any of the matchers has
472 stored an error message of some sort. */
474 if (gfc_error_check () == 0)
475 gfc_error_now ("Unclassifiable statement at %C");
479 gfc_error_recovery ();
485 decode_omp_directive (void)
490 gfc_enforce_clean_symbol_state ();
492 gfc_clear_error (); /* Clear any pending errors. */
493 gfc_clear_warning (); /* Clear any pending warnings. */
497 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
498 "or ELEMENTAL procedures");
499 gfc_error_recovery ();
503 if (gfc_implicit_pure (NULL
))
504 gfc_current_ns
->proc_name
->attr
.implicit_pure
= 0;
506 old_locus
= gfc_current_locus
;
508 /* General OpenMP directive matching: Instead of testing every possible
509 statement, we eliminate most possibilities by peeking at the
512 c
= gfc_peek_ascii_char ();
517 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
520 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
523 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
526 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
529 match ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
530 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
531 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
532 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
533 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
534 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
535 match ("end parallel sections", gfc_match_omp_eos
,
536 ST_OMP_END_PARALLEL_SECTIONS
);
537 match ("end parallel workshare", gfc_match_omp_eos
,
538 ST_OMP_END_PARALLEL_WORKSHARE
);
539 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
540 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
541 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
542 match ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
543 match ("end workshare", gfc_match_omp_end_nowait
,
544 ST_OMP_END_WORKSHARE
);
547 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
550 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
553 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
556 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
557 match ("parallel sections", gfc_match_omp_parallel_sections
,
558 ST_OMP_PARALLEL_SECTIONS
);
559 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
560 ST_OMP_PARALLEL_WORKSHARE
);
561 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
564 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
565 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
566 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
569 match ("task", gfc_match_omp_task
, ST_OMP_TASK
);
570 match ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
571 match ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
572 match ("threadprivate", gfc_match_omp_threadprivate
,
573 ST_OMP_THREADPRIVATE
);
575 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
579 /* All else has failed, so give up. See if any of the matchers has
580 stored an error message of some sort. */
582 if (gfc_error_check () == 0)
583 gfc_error_now ("Unclassifiable OpenMP directive at %C");
587 gfc_error_recovery ();
593 decode_gcc_attribute (void)
597 gfc_enforce_clean_symbol_state ();
599 gfc_clear_error (); /* Clear any pending errors. */
600 gfc_clear_warning (); /* Clear any pending warnings. */
601 old_locus
= gfc_current_locus
;
603 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
605 /* All else has failed, so give up. See if any of the matchers has
606 stored an error message of some sort. */
608 if (gfc_error_check () == 0)
609 gfc_error_now ("Unclassifiable GCC directive at %C");
613 gfc_error_recovery ();
621 /* Get the next statement in free form source. */
630 at_bol
= gfc_at_bol ();
631 gfc_gobble_whitespace ();
633 c
= gfc_peek_ascii_char ();
639 /* Found a statement label? */
640 m
= gfc_match_st_label (&gfc_statement_label
);
642 d
= gfc_peek_ascii_char ();
643 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
645 gfc_match_small_literal_int (&i
, &cnt
);
648 gfc_error_now ("Too many digits in statement label at %C");
651 gfc_error_now ("Zero is not a valid statement label at %C");
654 c
= gfc_next_ascii_char ();
657 if (!gfc_is_whitespace (c
))
658 gfc_error_now ("Non-numeric character in statement label at %C");
664 label_locus
= gfc_current_locus
;
666 gfc_gobble_whitespace ();
668 if (at_bol
&& gfc_peek_ascii_char () == ';')
670 gfc_error_now ("Semicolon at %C needs to be preceded by "
672 gfc_next_ascii_char (); /* Eat up the semicolon. */
676 if (gfc_match_eos () == MATCH_YES
)
678 gfc_warning_now ("Ignoring statement label in empty statement "
679 "at %L", &label_locus
);
680 gfc_free_st_label (gfc_statement_label
);
681 gfc_statement_label
= NULL
;
688 /* Comments have already been skipped by the time we get here,
689 except for GCC attributes and OpenMP directives. */
691 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
692 c
= gfc_peek_ascii_char ();
698 c
= gfc_next_ascii_char ();
699 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
700 gcc_assert (c
== "gcc$"[i
]);
702 gfc_gobble_whitespace ();
703 return decode_gcc_attribute ();
706 else if (c
== '$' && gfc_option
.gfc_flag_openmp
)
710 c
= gfc_next_ascii_char ();
711 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
712 gcc_assert (c
== "$omp"[i
]);
714 gcc_assert (c
== ' ' || c
== '\t');
715 gfc_gobble_whitespace ();
716 return decode_omp_directive ();
722 if (at_bol
&& c
== ';')
724 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
725 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
727 gfc_next_ascii_char (); /* Eat up the semicolon. */
731 return decode_statement ();
735 /* Get the next statement in fixed-form source. */
740 int label
, digit_flag
, i
;
745 return decode_statement ();
747 /* Skip past the current label field, parsing a statement label if
748 one is there. This is a weird number parser, since the number is
749 contained within five columns and can have any kind of embedded
750 spaces. We also check for characters that make the rest of the
756 for (i
= 0; i
< 5; i
++)
758 c
= gfc_next_char_literal (NONSTRING
);
775 label
= label
* 10 + ((unsigned char) c
- '0');
776 label_locus
= gfc_current_locus
;
780 /* Comments have already been skipped by the time we get
781 here, except for GCC attributes and OpenMP directives. */
784 c
= gfc_next_char_literal (NONSTRING
);
786 if (TOLOWER (c
) == 'g')
788 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
789 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
791 return decode_gcc_attribute ();
793 else if (c
== '$' && gfc_option
.gfc_flag_openmp
)
795 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
796 gcc_assert ((char) gfc_wide_tolower (c
) == "$omp"[i
]);
798 if (c
!= ' ' && c
!= '0')
800 gfc_buffer_error (0);
801 gfc_error ("Bad continuation line at %C");
805 return decode_omp_directive ();
809 /* Comments have already been skipped by the time we get
810 here so don't bother checking for them. */
813 gfc_buffer_error (0);
814 gfc_error ("Non-numeric character in statement label at %C");
822 gfc_warning_now ("Zero is not a valid statement label at %C");
825 /* We've found a valid statement label. */
826 gfc_statement_label
= gfc_get_st_label (label
);
830 /* Since this line starts a statement, it cannot be a continuation
831 of a previous statement. If we see something here besides a
832 space or zero, it must be a bad continuation line. */
834 c
= gfc_next_char_literal (NONSTRING
);
838 if (c
!= ' ' && c
!= '0')
840 gfc_buffer_error (0);
841 gfc_error ("Bad continuation line at %C");
845 /* Now that we've taken care of the statement label columns, we have
846 to make sure that the first nonblank character is not a '!'. If
847 it is, the rest of the line is a comment. */
851 loc
= gfc_current_locus
;
852 c
= gfc_next_char_literal (NONSTRING
);
854 while (gfc_is_whitespace (c
));
858 gfc_current_locus
= loc
;
863 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
864 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
865 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
870 if (gfc_match_eos () == MATCH_YES
)
873 /* At this point, we've got a nonblank statement to parse. */
874 return decode_statement ();
878 gfc_warning_now ("Ignoring statement label in empty statement at %L",
881 gfc_current_locus
.lb
->truncated
= 0;
887 /* Return the next non-ST_NONE statement to the caller. We also worry
888 about including files and the ends of include files at this stage. */
891 next_statement (void)
896 gfc_enforce_clean_symbol_state ();
898 gfc_new_block
= NULL
;
900 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
901 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
904 gfc_statement_label
= NULL
;
905 gfc_buffer_error (1);
910 gfc_skip_comments ();
918 if (gfc_define_undef_line ())
921 old_locus
= gfc_current_locus
;
923 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
929 gfc_buffer_error (0);
931 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
933 gfc_free_st_label (gfc_statement_label
);
934 gfc_statement_label
= NULL
;
935 gfc_current_locus
= old_locus
;
939 check_statement_label (st
);
945 /****************************** Parser ***********************************/
947 /* The parser subroutines are of type 'try' that fail if the file ends
950 /* Macros that expand to case-labels for various classes of
951 statements. Start with executable statements that directly do
954 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
955 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
956 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
957 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
958 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
959 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
960 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
961 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
962 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
963 case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
964 case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
966 /* Statements that mark other executable statements. */
968 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
969 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
970 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
971 case ST_OMP_PARALLEL: \
972 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
973 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
974 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
975 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
976 case ST_OMP_TASK: case ST_CRITICAL
978 /* Declaration statements */
980 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
981 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
982 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
985 /* Block end statements. Errors associated with interchanging these
986 are detected in gfc_match_end(). */
988 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
989 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
990 case ST_END_BLOCK: case ST_END_ASSOCIATE
993 /* Push a new state onto the stack. */
996 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
998 p
->state
= new_state
;
999 p
->previous
= gfc_state_stack
;
1001 p
->head
= p
->tail
= NULL
;
1002 p
->do_variable
= NULL
;
1004 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1005 construct statement was accepted right before pushing the state. Thus,
1006 the construct's gfc_code is available as tail of the parent state. */
1007 gcc_assert (gfc_state_stack
);
1008 p
->construct
= gfc_state_stack
->tail
;
1010 gfc_state_stack
= p
;
1014 /* Pop the current state. */
1018 gfc_state_stack
= gfc_state_stack
->previous
;
1022 /* Try to find the given state in the state stack. */
1025 gfc_find_state (gfc_compile_state state
)
1029 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1030 if (p
->state
== state
)
1033 return (p
== NULL
) ? FAILURE
: SUCCESS
;
1037 /* Starts a new level in the statement list. */
1040 new_level (gfc_code
*q
)
1044 p
= q
->block
= gfc_get_code ();
1046 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1052 /* Add the current new_st code structure and adds it to the current
1053 program unit. As a side-effect, it zeroes the new_st. */
1056 add_statement (void)
1060 p
= gfc_get_code ();
1063 p
->loc
= gfc_current_locus
;
1065 if (gfc_state_stack
->head
== NULL
)
1066 gfc_state_stack
->head
= p
;
1068 gfc_state_stack
->tail
->next
= p
;
1070 while (p
->next
!= NULL
)
1073 gfc_state_stack
->tail
= p
;
1075 gfc_clear_new_st ();
1081 /* Frees everything associated with the current statement. */
1084 undo_new_statement (void)
1086 gfc_free_statements (new_st
.block
);
1087 gfc_free_statements (new_st
.next
);
1088 gfc_free_statement (&new_st
);
1089 gfc_clear_new_st ();
1093 /* If the current statement has a statement label, make sure that it
1094 is allowed to, or should have one. */
1097 check_statement_label (gfc_statement st
)
1101 if (gfc_statement_label
== NULL
)
1103 if (st
== ST_FORMAT
)
1104 gfc_error ("FORMAT statement at %L does not have a statement label",
1111 case ST_END_PROGRAM
:
1112 case ST_END_FUNCTION
:
1113 case ST_END_SUBROUTINE
:
1117 case ST_END_CRITICAL
:
1119 case ST_END_ASSOCIATE
:
1122 type
= ST_LABEL_TARGET
;
1126 type
= ST_LABEL_FORMAT
;
1129 /* Statement labels are not restricted from appearing on a
1130 particular line. However, there are plenty of situations
1131 where the resulting label can't be referenced. */
1134 type
= ST_LABEL_BAD_TARGET
;
1138 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1140 new_st
.here
= gfc_statement_label
;
1144 /* Figures out what the enclosing program unit is. This will be a
1145 function, subroutine, program, block data or module. */
1148 gfc_enclosing_unit (gfc_compile_state
* result
)
1152 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1153 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1154 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1155 || p
->state
== COMP_PROGRAM
)
1164 *result
= COMP_PROGRAM
;
1169 /* Translate a statement enum to a string. */
1172 gfc_ascii_statement (gfc_statement st
)
1178 case ST_ARITHMETIC_IF
:
1179 p
= _("arithmetic IF");
1188 p
= _("attribute declaration");
1224 p
= _("data declaration");
1232 case ST_DERIVED_DECL
:
1233 p
= _("derived type declaration");
1247 case ST_END_ASSOCIATE
:
1248 p
= "END ASSOCIATE";
1253 case ST_END_BLOCK_DATA
:
1254 p
= "END BLOCK DATA";
1256 case ST_END_CRITICAL
:
1268 case ST_END_FUNCTION
:
1274 case ST_END_INTERFACE
:
1275 p
= "END INTERFACE";
1280 case ST_END_PROGRAM
:
1286 case ST_END_SUBROUTINE
:
1287 p
= "END SUBROUTINE";
1298 case ST_EQUIVALENCE
:
1310 case ST_FORALL_BLOCK
: /* Fall through */
1332 case ST_IMPLICIT_NONE
:
1333 p
= "IMPLICIT NONE";
1335 case ST_IMPLIED_ENDDO
:
1336 p
= _("implied END DO");
1365 case ST_MODULE_PROC
:
1366 p
= "MODULE PROCEDURE";
1398 case ST_SYNC_IMAGES
:
1401 case ST_SYNC_MEMORY
:
1416 case ST_WHERE_BLOCK
: /* Fall through */
1427 p
= _("assignment");
1429 case ST_POINTER_ASSIGNMENT
:
1430 p
= _("pointer assignment");
1432 case ST_SELECT_CASE
:
1435 case ST_SELECT_TYPE
:
1450 case ST_STATEMENT_FUNCTION
:
1451 p
= "STATEMENT FUNCTION";
1453 case ST_LABEL_ASSIGNMENT
:
1454 p
= "LABEL ASSIGNMENT";
1457 p
= "ENUM DEFINITION";
1460 p
= "ENUMERATOR DEFINITION";
1468 case ST_OMP_BARRIER
:
1469 p
= "!$OMP BARRIER";
1471 case ST_OMP_CRITICAL
:
1472 p
= "!$OMP CRITICAL";
1477 case ST_OMP_END_ATOMIC
:
1478 p
= "!$OMP END ATOMIC";
1480 case ST_OMP_END_CRITICAL
:
1481 p
= "!$OMP END CRITICAL";
1486 case ST_OMP_END_MASTER
:
1487 p
= "!$OMP END MASTER";
1489 case ST_OMP_END_ORDERED
:
1490 p
= "!$OMP END ORDERED";
1492 case ST_OMP_END_PARALLEL
:
1493 p
= "!$OMP END PARALLEL";
1495 case ST_OMP_END_PARALLEL_DO
:
1496 p
= "!$OMP END PARALLEL DO";
1498 case ST_OMP_END_PARALLEL_SECTIONS
:
1499 p
= "!$OMP END PARALLEL SECTIONS";
1501 case ST_OMP_END_PARALLEL_WORKSHARE
:
1502 p
= "!$OMP END PARALLEL WORKSHARE";
1504 case ST_OMP_END_SECTIONS
:
1505 p
= "!$OMP END SECTIONS";
1507 case ST_OMP_END_SINGLE
:
1508 p
= "!$OMP END SINGLE";
1510 case ST_OMP_END_TASK
:
1511 p
= "!$OMP END TASK";
1513 case ST_OMP_END_WORKSHARE
:
1514 p
= "!$OMP END WORKSHARE";
1522 case ST_OMP_ORDERED
:
1523 p
= "!$OMP ORDERED";
1525 case ST_OMP_PARALLEL
:
1526 p
= "!$OMP PARALLEL";
1528 case ST_OMP_PARALLEL_DO
:
1529 p
= "!$OMP PARALLEL DO";
1531 case ST_OMP_PARALLEL_SECTIONS
:
1532 p
= "!$OMP PARALLEL SECTIONS";
1534 case ST_OMP_PARALLEL_WORKSHARE
:
1535 p
= "!$OMP PARALLEL WORKSHARE";
1537 case ST_OMP_SECTIONS
:
1538 p
= "!$OMP SECTIONS";
1540 case ST_OMP_SECTION
:
1541 p
= "!$OMP SECTION";
1549 case ST_OMP_TASKWAIT
:
1550 p
= "!$OMP TASKWAIT";
1552 case ST_OMP_TASKYIELD
:
1553 p
= "!$OMP TASKYIELD";
1555 case ST_OMP_THREADPRIVATE
:
1556 p
= "!$OMP THREADPRIVATE";
1558 case ST_OMP_WORKSHARE
:
1559 p
= "!$OMP WORKSHARE";
1562 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1569 /* Create a symbol for the main program and assign it to ns->proc_name. */
1572 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1574 gfc_symbol
*main_program
;
1575 symbol_attribute attr
;
1577 gfc_get_symbol (name
, ns
, &main_program
);
1578 gfc_clear_attr (&attr
);
1579 attr
.flavor
= FL_PROGRAM
;
1580 attr
.proc
= PROC_UNKNOWN
;
1581 attr
.subroutine
= 1;
1582 attr
.access
= ACCESS_PUBLIC
;
1583 attr
.is_main_program
= 1;
1584 main_program
->attr
= attr
;
1585 main_program
->declared_at
= gfc_current_locus
;
1586 ns
->proc_name
= main_program
;
1587 gfc_commit_symbols ();
1591 /* Do whatever is necessary to accept the last statement. */
1594 accept_statement (gfc_statement st
)
1602 case ST_IMPLICIT_NONE
:
1603 gfc_set_implicit_none ();
1612 gfc_current_ns
->proc_name
= gfc_new_block
;
1615 /* If the statement is the end of a block, lay down a special code
1616 that allows a branch to the end of the block from within the
1617 construct. IF and SELECT are treated differently from DO
1618 (where EXEC_NOP is added inside the loop) for two
1620 1. END DO has a meaning in the sense that after a GOTO to
1621 it, the loop counter must be increased.
1622 2. IF blocks and SELECT blocks can consist of multiple
1623 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1624 Putting the label before the END IF would make the jump
1625 from, say, the ELSE IF block to the END IF illegal. */
1629 case ST_END_CRITICAL
:
1630 if (gfc_statement_label
!= NULL
)
1632 new_st
.op
= EXEC_END_NESTED_BLOCK
;
1637 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
1638 one parallel block. Thus, we add the special code to the nested block
1639 itself, instead of the parent one. */
1641 case ST_END_ASSOCIATE
:
1642 if (gfc_statement_label
!= NULL
)
1644 new_st
.op
= EXEC_END_BLOCK
;
1649 /* The end-of-program unit statements do not get the special
1650 marker and require a statement of some sort if they are a
1653 case ST_END_PROGRAM
:
1654 case ST_END_FUNCTION
:
1655 case ST_END_SUBROUTINE
:
1656 if (gfc_statement_label
!= NULL
)
1658 new_st
.op
= EXEC_RETURN
;
1663 new_st
.op
= EXEC_END_PROCEDURE
;
1679 gfc_commit_symbols ();
1680 gfc_warning_check ();
1681 gfc_clear_new_st ();
1685 /* Undo anything tentative that has been built for the current
1689 reject_statement (void)
1691 /* Revert to the previous charlen chain. */
1692 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
1693 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
1695 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
1696 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
1698 gfc_new_block
= NULL
;
1699 gfc_undo_symbols ();
1700 gfc_clear_warning ();
1701 undo_new_statement ();
1705 /* Generic complaint about an out of order statement. We also do
1706 whatever is necessary to clean up. */
1709 unexpected_statement (gfc_statement st
)
1711 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1713 reject_statement ();
1717 /* Given the next statement seen by the matcher, make sure that it is
1718 in proper order with the last. This subroutine is initialized by
1719 calling it with an argument of ST_NONE. If there is a problem, we
1720 issue an error and return FAILURE. Otherwise we return SUCCESS.
1722 Individual parsers need to verify that the statements seen are
1723 valid before calling here, i.e., ENTRY statements are not allowed in
1724 INTERFACE blocks. The following diagram is taken from the standard:
1726 +---------------------------------------+
1727 | program subroutine function module |
1728 +---------------------------------------+
1730 +---------------------------------------+
1732 +---------------------------------------+
1734 | +-----------+------------------+
1735 | | parameter | implicit |
1736 | +-----------+------------------+
1737 | format | | derived type |
1738 | entry | parameter | interface |
1739 | | data | specification |
1740 | | | statement func |
1741 | +-----------+------------------+
1742 | | data | executable |
1743 +--------+-----------+------------------+
1745 +---------------------------------------+
1746 | internal module/subprogram |
1747 +---------------------------------------+
1749 +---------------------------------------+
1758 ORDER_IMPLICIT_NONE
,
1766 enum state_order state
;
1767 gfc_statement last_statement
;
1773 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
1779 p
->state
= ORDER_START
;
1783 if (p
->state
> ORDER_USE
)
1785 p
->state
= ORDER_USE
;
1789 if (p
->state
> ORDER_IMPORT
)
1791 p
->state
= ORDER_IMPORT
;
1794 case ST_IMPLICIT_NONE
:
1795 if (p
->state
> ORDER_IMPLICIT_NONE
)
1798 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1799 statement disqualifies a USE but not an IMPLICIT NONE.
1800 Duplicate IMPLICIT NONEs are caught when the implicit types
1803 p
->state
= ORDER_IMPLICIT_NONE
;
1807 if (p
->state
> ORDER_IMPLICIT
)
1809 p
->state
= ORDER_IMPLICIT
;
1814 if (p
->state
< ORDER_IMPLICIT_NONE
)
1815 p
->state
= ORDER_IMPLICIT_NONE
;
1819 if (p
->state
>= ORDER_EXEC
)
1821 if (p
->state
< ORDER_IMPLICIT
)
1822 p
->state
= ORDER_IMPLICIT
;
1826 if (p
->state
< ORDER_SPEC
)
1827 p
->state
= ORDER_SPEC
;
1832 case ST_DERIVED_DECL
:
1834 if (p
->state
>= ORDER_EXEC
)
1836 if (p
->state
< ORDER_SPEC
)
1837 p
->state
= ORDER_SPEC
;
1842 if (p
->state
< ORDER_EXEC
)
1843 p
->state
= ORDER_EXEC
;
1847 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1848 gfc_ascii_statement (st
));
1851 /* All is well, record the statement in case we need it next time. */
1852 p
->where
= gfc_current_locus
;
1853 p
->last_statement
= st
;
1858 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1859 gfc_ascii_statement (st
),
1860 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1866 /* Handle an unexpected end of file. This is a show-stopper... */
1868 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1871 unexpected_eof (void)
1875 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1877 /* Memory cleanup. Move to "second to last". */
1878 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1881 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1884 longjmp (eof_buf
, 1);
1888 /* Parse the CONTAINS section of a derived type definition. */
1890 gfc_access gfc_typebound_default_access
;
1893 parse_derived_contains (void)
1896 bool seen_private
= false;
1897 bool seen_comps
= false;
1898 bool error_flag
= false;
1901 gcc_assert (gfc_current_state () == COMP_DERIVED
);
1902 gcc_assert (gfc_current_block ());
1904 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1906 if (gfc_current_block ()->attr
.sequence
)
1907 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1908 " section at %C", gfc_current_block ()->name
);
1909 if (gfc_current_block ()->attr
.is_bind_c
)
1910 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1911 " section at %C", gfc_current_block ()->name
);
1913 accept_statement (ST_CONTAINS
);
1914 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
1916 gfc_typebound_default_access
= ACCESS_PUBLIC
;
1922 st
= next_statement ();
1930 gfc_error ("Components in TYPE at %C must precede CONTAINS");
1934 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Type-bound"
1935 " procedure at %C") == FAILURE
)
1938 accept_statement (ST_PROCEDURE
);
1943 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: GENERIC binding"
1944 " at %C") == FAILURE
)
1947 accept_statement (ST_GENERIC
);
1952 if (gfc_notify_std (GFC_STD_F2003
,
1953 "Fortran 2003: FINAL procedure declaration"
1954 " at %C") == FAILURE
)
1957 accept_statement (ST_FINAL
);
1965 && (gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: Derived type "
1966 "definition at %C with empty CONTAINS "
1967 "section") == FAILURE
))
1970 /* ST_END_TYPE is accepted by parse_derived after return. */
1974 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1976 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1983 gfc_error ("PRIVATE statement at %C must precede procedure"
1990 gfc_error ("Duplicate PRIVATE statement at %C");
1994 accept_statement (ST_PRIVATE
);
1995 gfc_typebound_default_access
= ACCESS_PRIVATE
;
1996 seen_private
= true;
2000 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2004 gfc_error ("Already inside a CONTAINS block at %C");
2008 unexpected_statement (st
);
2016 reject_statement ();
2020 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2026 /* Parse a derived type. */
2029 parse_derived (void)
2031 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2035 gfc_component
*c
, *lock_comp
= NULL
;
2037 accept_statement (ST_DERIVED_DECL
);
2038 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2040 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2047 while (compiling_type
)
2049 st
= next_statement ();
2057 accept_statement (st
);
2062 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2069 if (!seen_component
)
2070 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Derived type "
2071 "definition at %C without components");
2073 accept_statement (ST_END_TYPE
);
2077 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
2079 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2086 gfc_error ("PRIVATE statement at %C must precede "
2087 "structure components");
2092 gfc_error ("Duplicate PRIVATE statement at %C");
2094 s
.sym
->component_access
= ACCESS_PRIVATE
;
2096 accept_statement (ST_PRIVATE
);
2103 gfc_error ("SEQUENCE statement at %C must precede "
2104 "structure components");
2108 if (gfc_current_block ()->attr
.sequence
)
2109 gfc_warning ("SEQUENCE attribute at %C already specified in "
2114 gfc_error ("Duplicate SEQUENCE statement at %C");
2118 gfc_add_sequence (&gfc_current_block ()->attr
,
2119 gfc_current_block ()->name
, NULL
);
2123 gfc_notify_std (GFC_STD_F2003
,
2124 "Fortran 2003: CONTAINS block in derived type"
2125 " definition at %C");
2127 accept_statement (ST_CONTAINS
);
2128 parse_derived_contains ();
2132 unexpected_statement (st
);
2137 /* need to verify that all fields of the derived type are
2138 * interoperable with C if the type is declared to be bind(c)
2140 sym
= gfc_current_block ();
2141 for (c
= sym
->components
; c
; c
= c
->next
)
2143 bool coarray
, lock_type
, allocatable
, pointer
;
2144 coarray
= lock_type
= allocatable
= pointer
= false;
2146 /* Look for allocatable components. */
2147 if (c
->attr
.allocatable
2148 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2149 && CLASS_DATA (c
)->attr
.allocatable
)
2150 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.alloc_comp
))
2153 sym
->attr
.alloc_comp
= 1;
2156 /* Look for pointer components. */
2158 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2159 && CLASS_DATA (c
)->attr
.class_pointer
)
2160 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2163 sym
->attr
.pointer_comp
= 1;
2166 /* Look for procedure pointer components. */
2167 if (c
->attr
.proc_pointer
2168 || (c
->ts
.type
== BT_DERIVED
2169 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2170 sym
->attr
.proc_pointer_comp
= 1;
2172 /* Looking for coarray components. */
2173 if (c
->attr
.codimension
2174 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2175 && CLASS_DATA (c
)->attr
.codimension
))
2178 sym
->attr
.coarray_comp
= 1;
2181 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
)
2184 if (!pointer
&& !allocatable
)
2185 sym
->attr
.coarray_comp
= 1;
2188 /* Looking for lock_type components. */
2189 if ((c
->ts
.type
== BT_DERIVED
2190 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2191 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2192 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2193 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2194 == INTMOD_ISO_FORTRAN_ENV
2195 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2196 == ISOFORTRAN_LOCK_TYPE
)
2197 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2198 && !allocatable
&& !pointer
))
2202 sym
->attr
.lock_comp
= 1;
2205 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2206 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2207 unless there are nondirect [allocatable or pointer] components
2208 involved (cf. 1.3.33.1 and 1.3.33.3). */
2210 if (pointer
&& !coarray
&& lock_type
)
2211 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2212 "codimension or be a subcomponent of a coarray, "
2213 "which is not possible as the component has the "
2214 "pointer attribute", c
->name
, &c
->loc
);
2215 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2216 && c
->ts
.u
.derived
->attr
.lock_comp
)
2217 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2218 "of type LOCK_TYPE, which must have a codimension or be a "
2219 "subcomponent of a coarray", c
->name
, &c
->loc
);
2221 if (lock_type
&& allocatable
&& !coarray
)
2222 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2223 "a codimension", c
->name
, &c
->loc
);
2224 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2225 && c
->ts
.u
.derived
->attr
.lock_comp
)
2226 gfc_error ("Allocatable component %s at %L must have a codimension as "
2227 "it has a noncoarray subcomponent of type LOCK_TYPE",
2230 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2231 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2232 "subcomponent of type LOCK_TYPE must have a codimension or "
2233 "be a subcomponent of a coarray. (Variables of type %s may "
2234 "not have a codimension as already a coarray "
2235 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2237 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2238 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2239 "subcomponent of type LOCK_TYPE must have a codimension or "
2240 "be a subcomponent of a coarray. (Variables of type %s may "
2241 "not have a codimension as %s at %L has a codimension or a "
2242 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2243 sym
->name
, c
->name
, &c
->loc
);
2245 /* Look for private components. */
2246 if (sym
->component_access
== ACCESS_PRIVATE
2247 || c
->attr
.access
== ACCESS_PRIVATE
2248 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2249 sym
->attr
.private_comp
= 1;
2252 if (!seen_component
)
2253 sym
->attr
.zero_comp
= 1;
2259 /* Parse an ENUM. */
2267 int seen_enumerator
= 0;
2269 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2273 while (compiling_enum
)
2275 st
= next_statement ();
2283 seen_enumerator
= 1;
2284 accept_statement (st
);
2289 if (!seen_enumerator
)
2290 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2291 accept_statement (st
);
2295 gfc_free_enum_history ();
2296 unexpected_statement (st
);
2304 /* Parse an interface. We must be able to deal with the possibility
2305 of recursive interfaces. The parse_spec() subroutine is mutually
2306 recursive with parse_interface(). */
2308 static gfc_statement
parse_spec (gfc_statement
);
2311 parse_interface (void)
2313 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2314 gfc_symbol
*prog_unit
, *sym
;
2315 gfc_interface_info save
;
2316 gfc_state_data s1
, s2
;
2320 accept_statement (ST_INTERFACE
);
2322 current_interface
.ns
= gfc_current_ns
;
2323 save
= current_interface
;
2325 sym
= (current_interface
.type
== INTERFACE_GENERIC
2326 || current_interface
.type
== INTERFACE_USER_OP
)
2327 ? gfc_new_block
: NULL
;
2329 push_state (&s1
, COMP_INTERFACE
, sym
);
2330 current_state
= COMP_NONE
;
2333 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2335 st
= next_statement ();
2343 if (st
== ST_SUBROUTINE
)
2344 new_state
= COMP_SUBROUTINE
;
2345 else if (st
== ST_FUNCTION
)
2346 new_state
= COMP_FUNCTION
;
2347 if (gfc_new_block
->attr
.pointer
)
2349 gfc_new_block
->attr
.pointer
= 0;
2350 gfc_new_block
->attr
.proc_pointer
= 1;
2352 if (gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2353 gfc_new_block
->formal
, NULL
) == FAILURE
)
2355 reject_statement ();
2356 gfc_free_namespace (gfc_current_ns
);
2362 case ST_MODULE_PROC
: /* The module procedure matcher makes
2363 sure the context is correct. */
2364 accept_statement (st
);
2365 gfc_free_namespace (gfc_current_ns
);
2368 case ST_END_INTERFACE
:
2369 gfc_free_namespace (gfc_current_ns
);
2370 gfc_current_ns
= current_interface
.ns
;
2374 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2375 gfc_ascii_statement (st
));
2376 reject_statement ();
2377 gfc_free_namespace (gfc_current_ns
);
2382 /* Make sure that the generic name has the right attribute. */
2383 if (current_interface
.type
== INTERFACE_GENERIC
2384 && current_state
== COMP_NONE
)
2386 if (new_state
== COMP_FUNCTION
&& sym
)
2387 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2388 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2389 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2391 current_state
= new_state
;
2394 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2396 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2397 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2398 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2399 "cannot be the same as an intrinsic type",
2400 gfc_new_block
->name
);
2403 push_state (&s2
, new_state
, gfc_new_block
);
2404 accept_statement (st
);
2405 prog_unit
= gfc_new_block
;
2406 prog_unit
->formal_ns
= gfc_current_ns
;
2407 proc_locus
= gfc_current_locus
;
2410 /* Read data declaration statements. */
2411 st
= parse_spec (ST_NONE
);
2413 /* Since the interface block does not permit an IMPLICIT statement,
2414 the default type for the function or the result must be taken
2415 from the formal namespace. */
2416 if (new_state
== COMP_FUNCTION
)
2418 if (prog_unit
->result
== prog_unit
2419 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2420 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2421 else if (prog_unit
->result
!= prog_unit
2422 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
2423 gfc_set_default_type (prog_unit
->result
, 1,
2424 prog_unit
->formal_ns
);
2427 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
2429 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2430 gfc_ascii_statement (st
));
2431 reject_statement ();
2435 /* Add EXTERNAL attribute to function or subroutine. */
2436 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
2437 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
2439 current_interface
= save
;
2440 gfc_add_interface (prog_unit
);
2443 if (current_interface
.ns
2444 && current_interface
.ns
->proc_name
2445 && strcmp (current_interface
.ns
->proc_name
->name
,
2446 prog_unit
->name
) == 0)
2447 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2448 "enclosing procedure", prog_unit
->name
, &proc_locus
);
2457 /* Associate function characteristics by going back to the function
2458 declaration and rematching the prefix. */
2461 match_deferred_characteristics (gfc_typespec
* ts
)
2464 match m
= MATCH_ERROR
;
2465 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2467 loc
= gfc_current_locus
;
2469 gfc_current_locus
= gfc_current_block ()->declared_at
;
2472 gfc_buffer_error (1);
2473 m
= gfc_match_prefix (ts
);
2474 gfc_buffer_error (0);
2476 if (ts
->type
== BT_DERIVED
)
2484 /* Only permit one go at the characteristic association. */
2488 /* Set the function locus correctly. If we have not found the
2489 function name, there is an error. */
2491 && gfc_match ("function% %n", name
) == MATCH_YES
2492 && strcmp (name
, gfc_current_block ()->name
) == 0)
2494 gfc_current_block ()->declared_at
= gfc_current_locus
;
2495 gfc_commit_symbols ();
2500 gfc_undo_symbols ();
2503 gfc_current_locus
=loc
;
2508 /* Check specification-expressions in the function result of the currently
2509 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2510 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2511 scope are not yet parsed so this has to be delayed up to parse_spec. */
2514 check_function_result_typed (void)
2516 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
2518 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
2519 gcc_assert (ts
->type
!= BT_UNKNOWN
);
2521 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2522 /* TODO: Extend when KIND type parameters are implemented. */
2523 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
2524 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
2528 /* Parse a set of specification statements. Returns the statement
2529 that doesn't fit. */
2531 static gfc_statement
2532 parse_spec (gfc_statement st
)
2535 bool function_result_typed
= false;
2536 bool bad_characteristic
= false;
2539 verify_st_order (&ss
, ST_NONE
, false);
2541 st
= next_statement ();
2543 /* If we are not inside a function or don't have a result specified so far,
2544 do nothing special about it. */
2545 if (gfc_current_state () != COMP_FUNCTION
)
2546 function_result_typed
= true;
2549 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
2552 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
2553 function_result_typed
= true;
2558 /* If we're inside a BLOCK construct, some statements are disallowed.
2559 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2560 or VALUE are also disallowed, but they don't have a particular ST_*
2561 key so we have to check for them individually in their matcher routine. */
2562 if (gfc_current_state () == COMP_BLOCK
)
2566 case ST_IMPLICIT_NONE
:
2569 case ST_EQUIVALENCE
:
2570 case ST_STATEMENT_FUNCTION
:
2571 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2572 gfc_ascii_statement (st
));
2573 reject_statement ();
2580 /* If we find a statement that can not be followed by an IMPLICIT statement
2581 (and thus we can expect to see none any further), type the function result
2582 if it has not yet been typed. Be careful not to give the END statement
2583 to verify_st_order! */
2584 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
2586 bool verify_now
= false;
2588 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
2593 verify_st_order (&dummyss
, ST_NONE
, false);
2594 verify_st_order (&dummyss
, st
, false);
2596 if (verify_st_order (&dummyss
, ST_IMPLICIT
, true) == FAILURE
)
2602 check_function_result_typed ();
2603 function_result_typed
= true;
2612 case ST_IMPLICIT_NONE
:
2614 if (!function_result_typed
)
2616 check_function_result_typed ();
2617 function_result_typed
= true;
2623 case ST_DATA
: /* Not allowed in interfaces */
2624 if (gfc_current_state () == COMP_INTERFACE
)
2634 case ST_DERIVED_DECL
:
2637 if (verify_st_order (&ss
, st
, false) == FAILURE
)
2639 reject_statement ();
2640 st
= next_statement ();
2650 case ST_DERIVED_DECL
:
2656 if (gfc_current_state () != COMP_MODULE
)
2658 gfc_error ("%s statement must appear in a MODULE",
2659 gfc_ascii_statement (st
));
2660 reject_statement ();
2664 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
2666 gfc_error ("%s statement at %C follows another accessibility "
2667 "specification", gfc_ascii_statement (st
));
2668 reject_statement ();
2672 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
2673 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2677 case ST_STATEMENT_FUNCTION
:
2678 if (gfc_current_state () == COMP_MODULE
)
2680 unexpected_statement (st
);
2688 accept_statement (st
);
2689 st
= next_statement ();
2693 accept_statement (st
);
2695 st
= next_statement ();
2698 case ST_GET_FCN_CHARACTERISTICS
:
2699 /* This statement triggers the association of a function's result
2701 ts
= &gfc_current_block ()->result
->ts
;
2702 if (match_deferred_characteristics (ts
) != MATCH_YES
)
2703 bad_characteristic
= true;
2705 st
= next_statement ();
2712 /* If match_deferred_characteristics failed, then there is an error. */
2713 if (bad_characteristic
)
2715 ts
= &gfc_current_block ()->result
->ts
;
2716 if (ts
->type
!= BT_DERIVED
)
2717 gfc_error ("Bad kind expression for function '%s' at %L",
2718 gfc_current_block ()->name
,
2719 &gfc_current_block ()->declared_at
);
2721 gfc_error ("The type for function '%s' at %L is not accessible",
2722 gfc_current_block ()->name
,
2723 &gfc_current_block ()->declared_at
);
2725 gfc_current_block ()->ts
.kind
= 0;
2726 /* Keep the derived type; if it's bad, it will be discovered later. */
2727 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
2728 ts
->type
= BT_UNKNOWN
;
2735 /* Parse a WHERE block, (not a simple WHERE statement). */
2738 parse_where_block (void)
2740 int seen_empty_else
;
2745 accept_statement (ST_WHERE_BLOCK
);
2746 top
= gfc_state_stack
->tail
;
2748 push_state (&s
, COMP_WHERE
, gfc_new_block
);
2750 d
= add_statement ();
2751 d
->expr1
= top
->expr1
;
2757 seen_empty_else
= 0;
2761 st
= next_statement ();
2767 case ST_WHERE_BLOCK
:
2768 parse_where_block ();
2773 accept_statement (st
);
2777 if (seen_empty_else
)
2779 gfc_error ("ELSEWHERE statement at %C follows previous "
2780 "unmasked ELSEWHERE");
2781 reject_statement ();
2785 if (new_st
.expr1
== NULL
)
2786 seen_empty_else
= 1;
2788 d
= new_level (gfc_state_stack
->head
);
2790 d
->expr1
= new_st
.expr1
;
2792 accept_statement (st
);
2797 accept_statement (st
);
2801 gfc_error ("Unexpected %s statement in WHERE block at %C",
2802 gfc_ascii_statement (st
));
2803 reject_statement ();
2807 while (st
!= ST_END_WHERE
);
2813 /* Parse a FORALL block (not a simple FORALL statement). */
2816 parse_forall_block (void)
2822 accept_statement (ST_FORALL_BLOCK
);
2823 top
= gfc_state_stack
->tail
;
2825 push_state (&s
, COMP_FORALL
, gfc_new_block
);
2827 d
= add_statement ();
2828 d
->op
= EXEC_FORALL
;
2833 st
= next_statement ();
2838 case ST_POINTER_ASSIGNMENT
:
2841 accept_statement (st
);
2844 case ST_WHERE_BLOCK
:
2845 parse_where_block ();
2848 case ST_FORALL_BLOCK
:
2849 parse_forall_block ();
2853 accept_statement (st
);
2860 gfc_error ("Unexpected %s statement in FORALL block at %C",
2861 gfc_ascii_statement (st
));
2863 reject_statement ();
2867 while (st
!= ST_END_FORALL
);
2873 static gfc_statement
parse_executable (gfc_statement
);
2875 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
2878 parse_if_block (void)
2887 accept_statement (ST_IF_BLOCK
);
2889 top
= gfc_state_stack
->tail
;
2890 push_state (&s
, COMP_IF
, gfc_new_block
);
2892 new_st
.op
= EXEC_IF
;
2893 d
= add_statement ();
2895 d
->expr1
= top
->expr1
;
2901 st
= parse_executable (ST_NONE
);
2911 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2912 "statement at %L", &else_locus
);
2914 reject_statement ();
2918 d
= new_level (gfc_state_stack
->head
);
2920 d
->expr1
= new_st
.expr1
;
2922 accept_statement (st
);
2929 gfc_error ("Duplicate ELSE statements at %L and %C",
2931 reject_statement ();
2936 else_locus
= gfc_current_locus
;
2938 d
= new_level (gfc_state_stack
->head
);
2941 accept_statement (st
);
2949 unexpected_statement (st
);
2953 while (st
!= ST_ENDIF
);
2956 accept_statement (st
);
2960 /* Parse a SELECT block. */
2963 parse_select_block (void)
2969 accept_statement (ST_SELECT_CASE
);
2971 cp
= gfc_state_stack
->tail
;
2972 push_state (&s
, COMP_SELECT
, gfc_new_block
);
2974 /* Make sure that the next statement is a CASE or END SELECT. */
2977 st
= next_statement ();
2980 if (st
== ST_END_SELECT
)
2982 /* Empty SELECT CASE is OK. */
2983 accept_statement (st
);
2990 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2993 reject_statement ();
2996 /* At this point, we're got a nonempty select block. */
2997 cp
= new_level (cp
);
3000 accept_statement (st
);
3004 st
= parse_executable (ST_NONE
);
3011 cp
= new_level (gfc_state_stack
->head
);
3013 gfc_clear_new_st ();
3015 accept_statement (st
);
3021 /* Can't have an executable statement because of
3022 parse_executable(). */
3024 unexpected_statement (st
);
3028 while (st
!= ST_END_SELECT
);
3031 accept_statement (st
);
3035 /* Pop the current selector from the SELECT TYPE stack. */
3038 select_type_pop (void)
3040 gfc_select_type_stack
*old
= select_type_stack
;
3041 select_type_stack
= old
->prev
;
3046 /* Parse a SELECT TYPE construct (F03:R821). */
3049 parse_select_type_block (void)
3055 accept_statement (ST_SELECT_TYPE
);
3057 cp
= gfc_state_stack
->tail
;
3058 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3060 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3064 st
= next_statement ();
3067 if (st
== ST_END_SELECT
)
3068 /* Empty SELECT CASE is OK. */
3070 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3073 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3074 "following SELECT TYPE at %C");
3076 reject_statement ();
3079 /* At this point, we're got a nonempty select block. */
3080 cp
= new_level (cp
);
3083 accept_statement (st
);
3087 st
= parse_executable (ST_NONE
);
3095 cp
= new_level (gfc_state_stack
->head
);
3097 gfc_clear_new_st ();
3099 accept_statement (st
);
3105 /* Can't have an executable statement because of
3106 parse_executable(). */
3108 unexpected_statement (st
);
3112 while (st
!= ST_END_SELECT
);
3116 accept_statement (st
);
3117 gfc_current_ns
= gfc_current_ns
->parent
;
3122 /* Given a symbol, make sure it is not an iteration variable for a DO
3123 statement. This subroutine is called when the symbol is seen in a
3124 context that causes it to become redefined. If the symbol is an
3125 iterator, we generate an error message and return nonzero. */
3128 gfc_check_do_variable (gfc_symtree
*st
)
3132 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3133 if (s
->do_variable
== st
)
3135 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3136 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3144 /* Checks to see if the current statement label closes an enddo.
3145 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3146 an error) if it incorrectly closes an ENDDO. */
3149 check_do_closure (void)
3153 if (gfc_statement_label
== NULL
)
3156 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3157 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3161 return 0; /* No loops to close */
3163 if (p
->ext
.end_do_label
== gfc_statement_label
)
3165 if (p
== gfc_state_stack
)
3168 gfc_error ("End of nonblock DO statement at %C is within another block");
3172 /* At this point, the label doesn't terminate the innermost loop.
3173 Make sure it doesn't terminate another one. */
3174 for (; p
; p
= p
->previous
)
3175 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3176 && p
->ext
.end_do_label
== gfc_statement_label
)
3178 gfc_error ("End of nonblock DO statement at %C is interwoven "
3179 "with another DO loop");
3187 /* Parse a series of contained program units. */
3189 static void parse_progunit (gfc_statement
);
3192 /* Parse a CRITICAL block. */
3195 parse_critical_block (void)
3201 s
.ext
.end_do_label
= new_st
.label1
;
3203 accept_statement (ST_CRITICAL
);
3204 top
= gfc_state_stack
->tail
;
3206 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3208 d
= add_statement ();
3209 d
->op
= EXEC_CRITICAL
;
3214 st
= parse_executable (ST_NONE
);
3222 case ST_END_CRITICAL
:
3223 if (s
.ext
.end_do_label
!= NULL
3224 && s
.ext
.end_do_label
!= gfc_statement_label
)
3225 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3226 "match CRITIAL label");
3228 if (gfc_statement_label
!= NULL
)
3230 new_st
.op
= EXEC_NOP
;
3236 unexpected_statement (st
);
3240 while (st
!= ST_END_CRITICAL
);
3243 accept_statement (st
);
3247 /* Set up the local namespace for a BLOCK construct. */
3250 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3252 gfc_namespace
* my_ns
;
3253 static int numblock
= 1;
3255 my_ns
= gfc_get_namespace (parent_ns
, 1);
3256 my_ns
->construct_entities
= 1;
3258 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3259 code generation (so it must not be NULL).
3260 We set its recursive argument if our container procedure is recursive, so
3261 that local variables are accordingly placed on the stack when it
3262 will be necessary. */
3264 my_ns
->proc_name
= gfc_new_block
;
3268 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3270 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3271 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3272 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3273 my_ns
->proc_name
->name
, NULL
);
3274 gcc_assert (t
== SUCCESS
);
3275 gfc_commit_symbol (my_ns
->proc_name
);
3278 if (parent_ns
->proc_name
)
3279 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3285 /* Parse a BLOCK construct. */
3288 parse_block_construct (void)
3290 gfc_namespace
* my_ns
;
3293 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: BLOCK construct at %C");
3295 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3297 new_st
.op
= EXEC_BLOCK
;
3298 new_st
.ext
.block
.ns
= my_ns
;
3299 new_st
.ext
.block
.assoc
= NULL
;
3300 accept_statement (ST_BLOCK
);
3302 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3303 gfc_current_ns
= my_ns
;
3305 parse_progunit (ST_NONE
);
3307 gfc_current_ns
= gfc_current_ns
->parent
;
3312 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3313 behind the scenes with compiler-generated variables. */
3316 parse_associate (void)
3318 gfc_namespace
* my_ns
;
3321 gfc_association_list
* a
;
3323 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ASSOCIATE construct at %C");
3325 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3327 new_st
.op
= EXEC_BLOCK
;
3328 new_st
.ext
.block
.ns
= my_ns
;
3329 gcc_assert (new_st
.ext
.block
.assoc
);
3331 /* Add all associate-names as BLOCK variables. Creating them is enough
3332 for now, they'll get their values during trans-* phase. */
3333 gfc_current_ns
= my_ns
;
3334 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3338 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3342 sym
->attr
.flavor
= FL_VARIABLE
;
3344 sym
->declared_at
= a
->where
;
3345 gfc_set_sym_referenced (sym
);
3347 /* Initialize the typespec. It is not available in all cases,
3348 however, as it may only be set on the target during resolution.
3349 Still, sometimes it helps to have it right now -- especially
3350 for parsing component references on the associate-name
3351 in case of assication to a derived-type. */
3352 sym
->ts
= a
->target
->ts
;
3355 accept_statement (ST_ASSOCIATE
);
3356 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
3359 st
= parse_executable (ST_NONE
);
3366 accept_statement (st
);
3367 my_ns
->code
= gfc_state_stack
->head
;
3371 unexpected_statement (st
);
3375 gfc_current_ns
= gfc_current_ns
->parent
;
3380 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3381 handled inside of parse_executable(), because they aren't really
3385 parse_do_block (void)
3394 s
.ext
.end_do_label
= new_st
.label1
;
3396 if (new_st
.ext
.iterator
!= NULL
)
3397 stree
= new_st
.ext
.iterator
->var
->symtree
;
3401 accept_statement (ST_DO
);
3403 top
= gfc_state_stack
->tail
;
3404 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
3407 s
.do_variable
= stree
;
3409 top
->block
= new_level (top
);
3410 top
->block
->op
= EXEC_DO
;
3413 st
= parse_executable (ST_NONE
);
3421 if (s
.ext
.end_do_label
!= NULL
3422 && s
.ext
.end_do_label
!= gfc_statement_label
)
3423 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3426 if (gfc_statement_label
!= NULL
)
3428 new_st
.op
= EXEC_NOP
;
3433 case ST_IMPLIED_ENDDO
:
3434 /* If the do-stmt of this DO construct has a do-construct-name,
3435 the corresponding end-do must be an end-do-stmt (with a matching
3436 name, but in that case we must have seen ST_ENDDO first).
3437 We only complain about this in pedantic mode. */
3438 if (gfc_current_block () != NULL
)
3439 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3440 &gfc_current_block()->declared_at
);
3445 unexpected_statement (st
);
3450 accept_statement (st
);
3454 /* Parse the statements of OpenMP do/parallel do. */
3456 static gfc_statement
3457 parse_omp_do (gfc_statement omp_st
)
3463 accept_statement (omp_st
);
3465 cp
= gfc_state_stack
->tail
;
3466 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3467 np
= new_level (cp
);
3473 st
= next_statement ();
3476 else if (st
== ST_DO
)
3479 unexpected_statement (st
);
3483 if (gfc_statement_label
!= NULL
3484 && gfc_state_stack
->previous
!= NULL
3485 && gfc_state_stack
->previous
->state
== COMP_DO
3486 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
3494 there should be no !$OMP END DO. */
3496 return ST_IMPLIED_ENDDO
;
3499 check_do_closure ();
3502 st
= next_statement ();
3503 if (st
== (omp_st
== ST_OMP_DO
? ST_OMP_END_DO
: ST_OMP_END_PARALLEL_DO
))
3505 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
3506 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3508 gcc_assert (new_st
.op
== EXEC_NOP
);
3509 gfc_clear_new_st ();
3510 gfc_commit_symbols ();
3511 gfc_warning_check ();
3512 st
= next_statement ();
3518 /* Parse the statements of OpenMP atomic directive. */
3520 static gfc_statement
3521 parse_omp_atomic (void)
3528 accept_statement (ST_OMP_ATOMIC
);
3530 cp
= gfc_state_stack
->tail
;
3531 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3532 np
= new_level (cp
);
3535 count
= 1 + (cp
->ext
.omp_atomic
== GFC_OMP_ATOMIC_CAPTURE
);
3539 st
= next_statement ();
3542 else if (st
== ST_ASSIGNMENT
)
3544 accept_statement (st
);
3548 unexpected_statement (st
);
3553 st
= next_statement ();
3554 if (st
== ST_OMP_END_ATOMIC
)
3556 gfc_clear_new_st ();
3557 gfc_commit_symbols ();
3558 gfc_warning_check ();
3559 st
= next_statement ();
3561 else if (cp
->ext
.omp_atomic
== GFC_OMP_ATOMIC_CAPTURE
)
3562 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3567 /* Parse the statements of an OpenMP structured block. */
3570 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
3572 gfc_statement st
, omp_end_st
;
3576 accept_statement (omp_st
);
3578 cp
= gfc_state_stack
->tail
;
3579 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3580 np
= new_level (cp
);
3586 case ST_OMP_PARALLEL
:
3587 omp_end_st
= ST_OMP_END_PARALLEL
;
3589 case ST_OMP_PARALLEL_SECTIONS
:
3590 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
3592 case ST_OMP_SECTIONS
:
3593 omp_end_st
= ST_OMP_END_SECTIONS
;
3595 case ST_OMP_ORDERED
:
3596 omp_end_st
= ST_OMP_END_ORDERED
;
3598 case ST_OMP_CRITICAL
:
3599 omp_end_st
= ST_OMP_END_CRITICAL
;
3602 omp_end_st
= ST_OMP_END_MASTER
;
3605 omp_end_st
= ST_OMP_END_SINGLE
;
3608 omp_end_st
= ST_OMP_END_TASK
;
3610 case ST_OMP_WORKSHARE
:
3611 omp_end_st
= ST_OMP_END_WORKSHARE
;
3613 case ST_OMP_PARALLEL_WORKSHARE
:
3614 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
3622 if (workshare_stmts_only
)
3624 /* Inside of !$omp workshare, only
3627 where statements and constructs
3628 forall statements and constructs
3632 are allowed. For !$omp critical these
3633 restrictions apply recursively. */
3636 st
= next_statement ();
3647 accept_statement (st
);
3650 case ST_WHERE_BLOCK
:
3651 parse_where_block ();
3654 case ST_FORALL_BLOCK
:
3655 parse_forall_block ();
3658 case ST_OMP_PARALLEL
:
3659 case ST_OMP_PARALLEL_SECTIONS
:
3660 parse_omp_structured_block (st
, false);
3663 case ST_OMP_PARALLEL_WORKSHARE
:
3664 case ST_OMP_CRITICAL
:
3665 parse_omp_structured_block (st
, true);
3668 case ST_OMP_PARALLEL_DO
:
3669 st
= parse_omp_do (st
);
3673 st
= parse_omp_atomic ();
3684 st
= next_statement ();
3688 st
= parse_executable (ST_NONE
);
3691 else if (st
== ST_OMP_SECTION
3692 && (omp_st
== ST_OMP_SECTIONS
3693 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
3695 np
= new_level (np
);
3699 else if (st
!= omp_end_st
)
3700 unexpected_statement (st
);
3702 while (st
!= omp_end_st
);
3706 case EXEC_OMP_END_NOWAIT
:
3707 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3709 case EXEC_OMP_CRITICAL
:
3710 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
3711 || (new_st
.ext
.omp_name
!= NULL
3712 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
3713 gfc_error ("Name after !$omp critical and !$omp end critical does "
3715 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
3717 case EXEC_OMP_END_SINGLE
:
3718 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
3719 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
3720 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
3721 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
3729 gfc_clear_new_st ();
3730 gfc_commit_symbols ();
3731 gfc_warning_check ();
3736 /* Accept a series of executable statements. We return the first
3737 statement that doesn't fit to the caller. Any block statements are
3738 passed on to the correct handler, which usually passes the buck
3741 static gfc_statement
3742 parse_executable (gfc_statement st
)
3747 st
= next_statement ();
3751 close_flag
= check_do_closure ();
3756 case ST_END_PROGRAM
:
3759 case ST_END_FUNCTION
:
3764 case ST_END_SUBROUTINE
:
3769 case ST_SELECT_CASE
:
3770 gfc_error ("%s statement at %C cannot terminate a non-block "
3771 "DO loop", gfc_ascii_statement (st
));
3787 accept_statement (st
);
3788 if (close_flag
== 1)
3789 return ST_IMPLIED_ENDDO
;
3793 parse_block_construct ();
3804 case ST_SELECT_CASE
:
3805 parse_select_block ();
3808 case ST_SELECT_TYPE
:
3809 parse_select_type_block();
3814 if (check_do_closure () == 1)
3815 return ST_IMPLIED_ENDDO
;
3819 parse_critical_block ();
3822 case ST_WHERE_BLOCK
:
3823 parse_where_block ();
3826 case ST_FORALL_BLOCK
:
3827 parse_forall_block ();
3830 case ST_OMP_PARALLEL
:
3831 case ST_OMP_PARALLEL_SECTIONS
:
3832 case ST_OMP_SECTIONS
:
3833 case ST_OMP_ORDERED
:
3834 case ST_OMP_CRITICAL
:
3838 parse_omp_structured_block (st
, false);
3841 case ST_OMP_WORKSHARE
:
3842 case ST_OMP_PARALLEL_WORKSHARE
:
3843 parse_omp_structured_block (st
, true);
3847 case ST_OMP_PARALLEL_DO
:
3848 st
= parse_omp_do (st
);
3849 if (st
== ST_IMPLIED_ENDDO
)
3854 st
= parse_omp_atomic ();
3861 st
= next_statement ();
3866 /* Fix the symbols for sibling functions. These are incorrectly added to
3867 the child namespace as the parser didn't know about this procedure. */
3870 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
3874 gfc_symbol
*old_sym
;
3876 sym
->attr
.referenced
= 1;
3877 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
3879 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
3881 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
3882 goto fixup_contained
;
3884 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
3885 && sym
->attr
.generic
&& sym
->attr
.function
)
3886 ||(sym
->attr
.flavor
== FL_DERIVED
3887 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
3888 goto fixup_contained
;
3890 old_sym
= st
->n
.sym
;
3891 if (old_sym
->ns
== ns
3892 && !old_sym
->attr
.contained
3894 /* By 14.6.1.3, host association should be excluded
3895 for the following. */
3896 && !(old_sym
->attr
.external
3897 || (old_sym
->ts
.type
!= BT_UNKNOWN
3898 && !old_sym
->attr
.implicit_type
)
3899 || old_sym
->attr
.flavor
== FL_PARAMETER
3900 || old_sym
->attr
.use_assoc
3901 || old_sym
->attr
.in_common
3902 || old_sym
->attr
.in_equivalence
3903 || old_sym
->attr
.data
3904 || old_sym
->attr
.dummy
3905 || old_sym
->attr
.result
3906 || old_sym
->attr
.dimension
3907 || old_sym
->attr
.allocatable
3908 || old_sym
->attr
.intrinsic
3909 || old_sym
->attr
.generic
3910 || old_sym
->attr
.flavor
== FL_NAMELIST
3911 || old_sym
->attr
.flavor
== FL_LABEL
3912 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
3914 /* Replace it with the symbol from the parent namespace. */
3918 gfc_release_symbol (old_sym
);
3922 /* Do the same for any contained procedures. */
3923 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
3928 parse_contained (int module
)
3930 gfc_namespace
*ns
, *parent_ns
, *tmp
;
3931 gfc_state_data s1
, s2
;
3935 int contains_statements
= 0;
3938 push_state (&s1
, COMP_CONTAINS
, NULL
);
3939 parent_ns
= gfc_current_ns
;
3943 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
3945 gfc_current_ns
->sibling
= parent_ns
->contained
;
3946 parent_ns
->contained
= gfc_current_ns
;
3949 /* Process the next available statement. We come here if we got an error
3950 and rejected the last statement. */
3951 st
= next_statement ();
3960 contains_statements
= 1;
3961 accept_statement (st
);
3964 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
3967 /* For internal procedures, create/update the symbol in the
3968 parent namespace. */
3972 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
3973 gfc_error ("Contained procedure '%s' at %C is already "
3974 "ambiguous", gfc_new_block
->name
);
3977 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
3978 &gfc_new_block
->declared_at
) ==
3981 if (st
== ST_FUNCTION
)
3982 gfc_add_function (&sym
->attr
, sym
->name
,
3983 &gfc_new_block
->declared_at
);
3985 gfc_add_subroutine (&sym
->attr
, sym
->name
,
3986 &gfc_new_block
->declared_at
);
3990 gfc_commit_symbols ();
3993 sym
= gfc_new_block
;
3995 /* Mark this as a contained function, so it isn't replaced
3996 by other module functions. */
3997 sym
->attr
.contained
= 1;
3998 sym
->attr
.referenced
= 1;
4000 /* Set implicit_pure so that it can be reset if any of the
4001 tests for purity fail. This is used for some optimisation
4002 during translation. */
4003 if (!sym
->attr
.pure
)
4004 sym
->attr
.implicit_pure
= 1;
4006 parse_progunit (ST_NONE
);
4008 /* Fix up any sibling functions that refer to this one. */
4009 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4010 /* Or refer to any of its alternate entry points. */
4011 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4012 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4014 gfc_current_ns
->code
= s2
.head
;
4015 gfc_current_ns
= parent_ns
;
4020 /* These statements are associated with the end of the host unit. */
4021 case ST_END_FUNCTION
:
4023 case ST_END_PROGRAM
:
4024 case ST_END_SUBROUTINE
:
4025 accept_statement (st
);
4029 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4030 gfc_ascii_statement (st
));
4031 reject_statement ();
4037 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
4038 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
4040 /* The first namespace in the list is guaranteed to not have
4041 anything (worthwhile) in it. */
4042 tmp
= gfc_current_ns
;
4043 gfc_current_ns
= parent_ns
;
4044 if (seen_error
&& tmp
->refs
> 1)
4045 gfc_free_namespace (tmp
);
4047 ns
= gfc_current_ns
->contained
;
4048 gfc_current_ns
->contained
= ns
->sibling
;
4049 gfc_free_namespace (ns
);
4052 if (!contains_statements
)
4053 gfc_notify_std (GFC_STD_F2008
, "Fortran 2008: CONTAINS statement without "
4054 "FUNCTION or SUBROUTINE statement at %C");
4058 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4061 parse_progunit (gfc_statement st
)
4066 st
= parse_spec (st
);
4073 /* This is not allowed within BLOCK! */
4074 if (gfc_current_state () != COMP_BLOCK
)
4079 accept_statement (st
);
4086 if (gfc_current_state () == COMP_FUNCTION
)
4087 gfc_check_function_type (gfc_current_ns
);
4092 st
= parse_executable (st
);
4100 /* This is not allowed within BLOCK! */
4101 if (gfc_current_state () != COMP_BLOCK
)
4106 accept_statement (st
);
4113 unexpected_statement (st
);
4114 reject_statement ();
4115 st
= next_statement ();
4121 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4122 if (p
->state
== COMP_CONTAINS
)
4125 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
4130 gfc_error ("CONTAINS statement at %C is already in a contained "
4132 reject_statement ();
4133 st
= next_statement ();
4137 parse_contained (0);
4140 gfc_current_ns
->code
= gfc_state_stack
->head
;
4144 /* Come here to complain about a global symbol already in use as
4148 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
4153 where
= &gfc_current_locus
;
4163 case GSYM_SUBROUTINE
:
4164 name
= "SUBROUTINE";
4169 case GSYM_BLOCK_DATA
:
4170 name
= "BLOCK DATA";
4176 gfc_internal_error ("gfc_global_used(): Bad type");
4180 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
4181 sym
->name
, where
, name
, &sym
->where
);
4185 /* Parse a block data program unit. */
4188 parse_block_data (void)
4191 static locus blank_locus
;
4192 static int blank_block
=0;
4195 gfc_current_ns
->proc_name
= gfc_new_block
;
4196 gfc_current_ns
->is_block_data
= 1;
4198 if (gfc_new_block
== NULL
)
4201 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4202 "prior BLOCK DATA at %L", &blank_locus
);
4206 blank_locus
= gfc_current_locus
;
4211 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4213 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
4214 gfc_global_used(s
, NULL
);
4217 s
->type
= GSYM_BLOCK_DATA
;
4218 s
->where
= gfc_current_locus
;
4223 st
= parse_spec (ST_NONE
);
4225 while (st
!= ST_END_BLOCK_DATA
)
4227 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4228 gfc_ascii_statement (st
));
4229 reject_statement ();
4230 st
= next_statement ();
4235 /* Parse a module subprogram. */
4243 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4244 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
4245 gfc_global_used(s
, NULL
);
4248 s
->type
= GSYM_MODULE
;
4249 s
->where
= gfc_current_locus
;
4253 st
= parse_spec (ST_NONE
);
4262 parse_contained (1);
4266 accept_statement (st
);
4270 gfc_error ("Unexpected %s statement in MODULE at %C",
4271 gfc_ascii_statement (st
));
4273 reject_statement ();
4274 st
= next_statement ();
4278 s
->ns
= gfc_current_ns
;
4282 /* Add a procedure name to the global symbol table. */
4285 add_global_procedure (int sub
)
4289 s
= gfc_get_gsymbol(gfc_new_block
->name
);
4292 || (s
->type
!= GSYM_UNKNOWN
4293 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
4294 gfc_global_used(s
, NULL
);
4297 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
4298 s
->where
= gfc_current_locus
;
4300 s
->ns
= gfc_current_ns
;
4305 /* Add a program to the global symbol table. */
4308 add_global_program (void)
4312 if (gfc_new_block
== NULL
)
4314 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4316 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
4317 gfc_global_used(s
, NULL
);
4320 s
->type
= GSYM_PROGRAM
;
4321 s
->where
= gfc_current_locus
;
4323 s
->ns
= gfc_current_ns
;
4328 /* Resolve all the program units when whole file scope option
4331 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4333 gfc_free_dt_list ();
4334 gfc_current_ns
= gfc_global_ns_list
;
4335 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4337 if (gfc_current_ns
->proc_name
4338 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4339 continue; /* Already resolved. */
4341 if (gfc_current_ns
->proc_name
)
4342 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4343 gfc_resolve (gfc_current_ns
);
4344 gfc_current_ns
->derived_types
= gfc_derived_types
;
4345 gfc_derived_types
= NULL
;
4351 clean_up_modules (gfc_gsymbol
*gsym
)
4356 clean_up_modules (gsym
->left
);
4357 clean_up_modules (gsym
->right
);
4359 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
4362 gfc_current_ns
= gsym
->ns
;
4363 gfc_derived_types
= gfc_current_ns
->derived_types
;
4370 /* Translate all the program units when whole file scope option
4371 is active. This could be in a different order to resolution if
4372 there are forward references in the file. */
4374 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
,
4379 gfc_current_ns
= gfc_global_ns_list
;
4380 gfc_get_errors (NULL
, &errors
);
4382 /* If the main program is in the translation unit and we have
4383 -fcoarray=libs, generate the static variables. */
4384 if (gfc_option
.coarray
== GFC_FCOARRAY_LIB
&& main_in_tu
)
4385 gfc_init_coarray_decl (true);
4387 /* We first translate all modules to make sure that later parts
4388 of the program can use the decl. Then we translate the nonmodules. */
4390 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4392 if (!gfc_current_ns
->proc_name
4393 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4396 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4397 gfc_derived_types
= gfc_current_ns
->derived_types
;
4398 gfc_generate_module_code (gfc_current_ns
);
4399 gfc_current_ns
->translated
= 1;
4402 gfc_current_ns
= gfc_global_ns_list
;
4403 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4405 if (gfc_current_ns
->proc_name
4406 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4409 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4410 gfc_derived_types
= gfc_current_ns
->derived_types
;
4411 gfc_generate_code (gfc_current_ns
);
4412 gfc_current_ns
->translated
= 1;
4415 /* Clean up all the namespaces after translation. */
4416 gfc_current_ns
= gfc_global_ns_list
;
4417 for (;gfc_current_ns
;)
4421 if (gfc_current_ns
->proc_name
4422 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4424 gfc_current_ns
= gfc_current_ns
->sibling
;
4428 ns
= gfc_current_ns
->sibling
;
4429 gfc_derived_types
= gfc_current_ns
->derived_types
;
4431 gfc_current_ns
= ns
;
4434 clean_up_modules (gfc_gsym_root
);
4438 /* Top level parser. */
4441 gfc_parse_file (void)
4443 int seen_program
, errors_before
, errors
;
4444 gfc_state_data top
, s
;
4447 gfc_namespace
*next
;
4449 gfc_start_source_files ();
4451 top
.state
= COMP_NONE
;
4453 top
.previous
= NULL
;
4454 top
.head
= top
.tail
= NULL
;
4455 top
.do_variable
= NULL
;
4457 gfc_state_stack
= &top
;
4459 gfc_clear_new_st ();
4461 gfc_statement_label
= NULL
;
4463 if (setjmp (eof_buf
))
4464 return FAILURE
; /* Come here on unexpected EOF */
4466 /* Prepare the global namespace that will contain the
4468 gfc_global_ns_list
= next
= NULL
;
4472 /* Exit early for empty files. */
4478 st
= next_statement ();
4487 goto duplicate_main
;
4489 prog_locus
= gfc_current_locus
;
4491 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4492 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
4493 accept_statement (st
);
4494 add_global_program ();
4495 parse_progunit (ST_NONE
);
4496 if (gfc_option
.flag_whole_file
)
4501 add_global_procedure (1);
4502 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
4503 accept_statement (st
);
4504 parse_progunit (ST_NONE
);
4505 if (gfc_option
.flag_whole_file
)
4510 add_global_procedure (0);
4511 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
4512 accept_statement (st
);
4513 parse_progunit (ST_NONE
);
4514 if (gfc_option
.flag_whole_file
)
4519 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
4520 accept_statement (st
);
4521 parse_block_data ();
4525 push_state (&s
, COMP_MODULE
, gfc_new_block
);
4526 accept_statement (st
);
4528 gfc_get_errors (NULL
, &errors_before
);
4532 /* Anything else starts a nameless main program block. */
4535 goto duplicate_main
;
4537 prog_locus
= gfc_current_locus
;
4539 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
4540 main_program_symbol (gfc_current_ns
, "MAIN__");
4541 parse_progunit (st
);
4542 if (gfc_option
.flag_whole_file
)
4547 /* Handle the non-program units. */
4548 gfc_current_ns
->code
= s
.head
;
4550 gfc_resolve (gfc_current_ns
);
4552 /* Dump the parse tree if requested. */
4553 if (gfc_option
.dump_fortran_original
)
4554 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4556 gfc_get_errors (NULL
, &errors
);
4557 if (s
.state
== COMP_MODULE
)
4559 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
4560 if (!gfc_option
.flag_whole_file
)
4563 gfc_generate_module_code (gfc_current_ns
);
4569 gfc_current_ns
->derived_types
= gfc_derived_types
;
4570 gfc_derived_types
= NULL
;
4577 gfc_generate_code (gfc_current_ns
);
4585 /* The main program and non-contained procedures are put
4586 in the global namespace list, so that they can be processed
4587 later and all their interfaces resolved. */
4588 gfc_current_ns
->code
= s
.head
;
4591 for (; next
->sibling
; next
= next
->sibling
)
4593 next
->sibling
= gfc_current_ns
;
4596 gfc_global_ns_list
= gfc_current_ns
;
4598 next
= gfc_current_ns
;
4605 if (!gfc_option
.flag_whole_file
)
4608 /* Do the resolution. */
4609 resolve_all_program_units (gfc_global_ns_list
);
4611 /* Do the parse tree dump. */
4613 = gfc_option
.dump_fortran_original
? gfc_global_ns_list
: NULL
;
4615 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4616 if (!gfc_current_ns
->proc_name
4617 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4619 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
4620 fputs ("------------------------------------------\n\n", stdout
);
4623 /* Do the translation. */
4624 translate_all_program_units (gfc_global_ns_list
, seen_program
);
4628 gfc_end_source_files ();
4632 /* If we see a duplicate main program, shut down. If the second
4633 instance is an implied main program, i.e. data decls or executable
4634 statements, we're in for lots of errors. */
4635 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
4636 reject_statement ();