2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
30 /* Current statement label. Zero means no statement label. Because new_st
31 can get wiped during statement matching, we have to keep it separate. */
33 gfc_st_label
*gfc_statement_label
;
35 static locus label_locus
;
36 static jmp_buf eof_buf
;
38 gfc_state_data
*gfc_state_stack
;
39 static bool last_was_use_stmt
= false;
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 /* Load symbols from all USE statements encountered in this scoping unit. */
82 gfc_error_buf old_error
;
84 gfc_push_error (&old_error
);
88 gfc_pop_error (&old_error
);
89 gfc_commit_symbols ();
91 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
92 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
93 last_was_use_stmt
= false;
97 /* Figure out what the next statement is, (mostly) regardless of
98 proper ordering. The do...while(0) is there to prevent if/else
101 #define match(keyword, subr, st) \
103 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
106 undo_new_statement (); \
110 /* This is a specialist version of decode_statement that is used
111 for the specification statements in a function, whose
112 characteristics are deferred into the specification statements.
113 eg.: INTEGER (king = mykind) foo ()
114 USE mymodule, ONLY mykind.....
115 The KIND parameter needs a return after USE or IMPORT, whereas
116 derived type declarations can occur anywhere, up the executable
117 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
118 out of the correct kind of specification statements. */
120 decode_specification_statement (void)
126 if (gfc_match_eos () == MATCH_YES
)
129 old_locus
= gfc_current_locus
;
131 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
133 last_was_use_stmt
= true;
138 undo_new_statement ();
139 if (last_was_use_stmt
)
143 match ("import", gfc_match_import
, ST_IMPORT
);
145 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
148 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
149 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
150 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
152 /* General statement matching: Instead of testing every possible
153 statement, we eliminate most possibilities by peeking at the
156 c
= gfc_peek_ascii_char ();
161 match ("abstract% interface", gfc_match_abstract_interface
,
163 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
164 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
168 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
172 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
173 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
177 match ("data", gfc_match_data
, ST_DATA
);
178 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
182 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
183 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
184 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
185 match ("external", gfc_match_external
, ST_ATTR_DECL
);
189 match ("format", gfc_match_format
, ST_FORMAT
);
196 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
197 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
198 match ("interface", gfc_match_interface
, ST_INTERFACE
);
199 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
200 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
207 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
211 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
215 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
216 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
217 if (gfc_match_private (&st
) == MATCH_YES
)
219 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
220 if (gfc_match_public (&st
) == MATCH_YES
)
222 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
229 match ("save", gfc_match_save
, ST_ATTR_DECL
);
233 match ("target", gfc_match_target
, ST_ATTR_DECL
);
234 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
241 match ("value", gfc_match_value
, ST_ATTR_DECL
);
242 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
249 /* This is not a specification statement. See if any of the matchers
250 has stored an error message of some sort. */
254 gfc_buffer_error (0);
255 gfc_current_locus
= old_locus
;
257 return ST_GET_FCN_CHARACTERISTICS
;
261 /* This is the primary 'decode_statement'. */
263 decode_statement (void)
271 gfc_enforce_clean_symbol_state ();
273 gfc_clear_error (); /* Clear any pending errors. */
274 gfc_clear_warning (); /* Clear any pending warnings. */
276 gfc_matching_function
= false;
278 if (gfc_match_eos () == MATCH_YES
)
281 if (gfc_current_state () == COMP_FUNCTION
282 && gfc_current_block ()->result
->ts
.kind
== -1)
283 return decode_specification_statement ();
285 old_locus
= gfc_current_locus
;
287 c
= gfc_peek_ascii_char ();
291 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
293 last_was_use_stmt
= true;
297 undo_new_statement ();
300 if (last_was_use_stmt
)
303 /* Try matching a data declaration or function declaration. The
304 input "REALFUNCTIONA(N)" can mean several things in different
305 contexts, so it (and its relatives) get special treatment. */
307 if (gfc_current_state () == COMP_NONE
308 || gfc_current_state () == COMP_INTERFACE
309 || gfc_current_state () == COMP_CONTAINS
)
311 gfc_matching_function
= true;
312 m
= gfc_match_function_decl ();
315 else if (m
== MATCH_ERROR
)
319 gfc_current_locus
= old_locus
;
321 gfc_matching_function
= false;
324 /* Match statements whose error messages are meant to be overwritten
325 by something better. */
327 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
328 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
329 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
331 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
332 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
334 /* Try to match a subroutine statement, which has the same optional
335 prefixes that functions can have. */
337 if (gfc_match_subroutine () == MATCH_YES
)
338 return ST_SUBROUTINE
;
340 gfc_current_locus
= old_locus
;
342 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
343 statements, which might begin with a block label. The match functions for
344 these statements are unusual in that their keyword is not seen before
345 the matcher is called. */
347 if (gfc_match_if (&st
) == MATCH_YES
)
350 gfc_current_locus
= old_locus
;
352 if (gfc_match_where (&st
) == MATCH_YES
)
355 gfc_current_locus
= old_locus
;
357 if (gfc_match_forall (&st
) == MATCH_YES
)
360 gfc_current_locus
= old_locus
;
362 match (NULL
, gfc_match_do
, ST_DO
);
363 match (NULL
, gfc_match_block
, ST_BLOCK
);
364 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
365 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
366 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
368 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
369 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
371 gfc_current_ns
= gfc_current_ns
->parent
;
372 gfc_free_namespace (ns
);
374 /* General statement matching: Instead of testing every possible
375 statement, we eliminate most possibilities by peeking at the
381 match ("abstract% interface", gfc_match_abstract_interface
,
383 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
384 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
385 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
386 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
390 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
391 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
392 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
396 match ("call", gfc_match_call
, ST_CALL
);
397 match ("close", gfc_match_close
, ST_CLOSE
);
398 match ("continue", gfc_match_continue
, ST_CONTINUE
);
399 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
400 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
401 match ("case", gfc_match_case
, ST_CASE
);
402 match ("common", gfc_match_common
, ST_COMMON
);
403 match ("contains", gfc_match_eos
, ST_CONTAINS
);
404 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
405 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
409 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
410 match ("data", gfc_match_data
, ST_DATA
);
411 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
415 match ("end file", gfc_match_endfile
, ST_END_FILE
);
416 match ("exit", gfc_match_exit
, ST_EXIT
);
417 match ("else", gfc_match_else
, ST_ELSE
);
418 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
419 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
420 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
421 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
423 if (gfc_match_end (&st
) == MATCH_YES
)
426 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
427 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
428 match ("external", gfc_match_external
, ST_ATTR_DECL
);
432 match ("final", gfc_match_final_decl
, ST_FINAL
);
433 match ("flush", gfc_match_flush
, ST_FLUSH
);
434 match ("format", gfc_match_format
, ST_FORMAT
);
438 match ("generic", gfc_match_generic
, ST_GENERIC
);
439 match ("go to", gfc_match_goto
, ST_GOTO
);
443 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
444 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
445 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
446 match ("import", gfc_match_import
, ST_IMPORT
);
447 match ("interface", gfc_match_interface
, ST_INTERFACE
);
448 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
449 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
453 match ("lock", gfc_match_lock
, ST_LOCK
);
457 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
458 match ("module", gfc_match_module
, ST_MODULE
);
462 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
463 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
467 match ("open", gfc_match_open
, ST_OPEN
);
468 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
472 match ("print", gfc_match_print
, ST_WRITE
);
473 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
474 match ("pause", gfc_match_pause
, ST_PAUSE
);
475 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
476 if (gfc_match_private (&st
) == MATCH_YES
)
478 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
479 match ("program", gfc_match_program
, ST_PROGRAM
);
480 if (gfc_match_public (&st
) == MATCH_YES
)
482 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
486 match ("read", gfc_match_read
, ST_READ
);
487 match ("return", gfc_match_return
, ST_RETURN
);
488 match ("rewind", gfc_match_rewind
, ST_REWIND
);
492 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
493 match ("stop", gfc_match_stop
, ST_STOP
);
494 match ("save", gfc_match_save
, ST_ATTR_DECL
);
495 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
496 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
497 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
501 match ("target", gfc_match_target
, ST_ATTR_DECL
);
502 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
503 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
507 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
511 match ("value", gfc_match_value
, ST_ATTR_DECL
);
512 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
516 match ("wait", gfc_match_wait
, ST_WAIT
);
517 match ("write", gfc_match_write
, ST_WRITE
);
521 /* All else has failed, so give up. See if any of the matchers has
522 stored an error message of some sort. */
524 if (gfc_error_check () == 0)
525 gfc_error_now ("Unclassifiable statement at %C");
529 gfc_error_recovery ();
535 decode_oacc_directive (void)
540 gfc_enforce_clean_symbol_state ();
542 gfc_clear_error (); /* Clear any pending errors. */
543 gfc_clear_warning (); /* Clear any pending warnings. */
547 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
549 gfc_error_recovery ();
553 gfc_unset_implicit_pure (NULL
);
555 old_locus
= gfc_current_locus
;
557 /* General OpenACC directive matching: Instead of testing every possible
558 statement, we eliminate most possibilities by peeking at the
561 c
= gfc_peek_ascii_char ();
566 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
569 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
570 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
573 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
574 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
575 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
576 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
577 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
578 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
579 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
580 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
581 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
584 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
587 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
588 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
591 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
592 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
595 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
598 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
601 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
605 /* Directive not found or stored an error message.
606 Check and give up. */
608 if (gfc_error_check () == 0)
609 gfc_error_now ("Unclassifiable OpenACC directive at %C");
613 gfc_error_recovery ();
619 decode_omp_directive (void)
624 gfc_enforce_clean_symbol_state ();
626 gfc_clear_error (); /* Clear any pending errors. */
627 gfc_clear_warning (); /* Clear any pending warnings. */
631 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
632 "or ELEMENTAL procedures");
633 gfc_error_recovery ();
637 gfc_unset_implicit_pure (NULL
);
639 old_locus
= gfc_current_locus
;
641 /* General OpenMP directive matching: Instead of testing every possible
642 statement, we eliminate most possibilities by peeking at the
645 c
= gfc_peek_ascii_char ();
650 match ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
653 match ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
656 match ("cancellation% point", gfc_match_omp_cancellation_point
,
657 ST_OMP_CANCELLATION_POINT
);
658 match ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
659 match ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
662 match ("declare simd", gfc_match_omp_declare_simd
,
663 ST_OMP_DECLARE_SIMD
);
664 match ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
665 match ("do", gfc_match_omp_do
, ST_OMP_DO
);
668 match ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
669 match ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
670 match ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
671 match ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
672 match ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
673 match ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
674 match ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
675 match ("end parallel do simd", gfc_match_omp_eos
,
676 ST_OMP_END_PARALLEL_DO_SIMD
);
677 match ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
678 match ("end parallel sections", gfc_match_omp_eos
,
679 ST_OMP_END_PARALLEL_SECTIONS
);
680 match ("end parallel workshare", gfc_match_omp_eos
,
681 ST_OMP_END_PARALLEL_WORKSHARE
);
682 match ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
683 match ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
684 match ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
685 match ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
686 match ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
687 match ("end workshare", gfc_match_omp_end_nowait
,
688 ST_OMP_END_WORKSHARE
);
691 match ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
694 match ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
697 match ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
700 match ("parallel do simd", gfc_match_omp_parallel_do_simd
,
701 ST_OMP_PARALLEL_DO_SIMD
);
702 match ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
703 match ("parallel sections", gfc_match_omp_parallel_sections
,
704 ST_OMP_PARALLEL_SECTIONS
);
705 match ("parallel workshare", gfc_match_omp_parallel_workshare
,
706 ST_OMP_PARALLEL_WORKSHARE
);
707 match ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
710 match ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
711 match ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
712 match ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
713 match ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
716 match ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
717 match ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
718 match ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
719 match ("task", gfc_match_omp_task
, ST_OMP_TASK
);
720 match ("threadprivate", gfc_match_omp_threadprivate
,
721 ST_OMP_THREADPRIVATE
);
724 match ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
728 /* All else has failed, so give up. See if any of the matchers has
729 stored an error message of some sort. */
731 if (gfc_error_check () == 0)
732 gfc_error_now ("Unclassifiable OpenMP directive at %C");
736 gfc_error_recovery ();
742 decode_gcc_attribute (void)
746 gfc_enforce_clean_symbol_state ();
748 gfc_clear_error (); /* Clear any pending errors. */
749 gfc_clear_warning (); /* Clear any pending warnings. */
750 old_locus
= gfc_current_locus
;
752 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
754 /* All else has failed, so give up. See if any of the matchers has
755 stored an error message of some sort. */
757 if (gfc_error_check () == 0)
758 gfc_error_now ("Unclassifiable GCC directive at %C");
762 gfc_error_recovery ();
769 /* Assert next length characters to be equal to token in free form. */
772 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
777 c
= gfc_next_ascii_char ();
778 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
779 gcc_assert (c
== token
[i
]);
781 gcc_assert (gfc_is_whitespace(c
));
782 gfc_gobble_whitespace ();
783 if (last_was_use_stmt
)
787 /* Get the next statement in free form source. */
796 at_bol
= gfc_at_bol ();
797 gfc_gobble_whitespace ();
799 c
= gfc_peek_ascii_char ();
805 /* Found a statement label? */
806 m
= gfc_match_st_label (&gfc_statement_label
);
808 d
= gfc_peek_ascii_char ();
809 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
811 gfc_match_small_literal_int (&i
, &cnt
);
814 gfc_error_now ("Too many digits in statement label at %C");
817 gfc_error_now ("Zero is not a valid statement label at %C");
820 c
= gfc_next_ascii_char ();
823 if (!gfc_is_whitespace (c
))
824 gfc_error_now ("Non-numeric character in statement label at %C");
830 label_locus
= gfc_current_locus
;
832 gfc_gobble_whitespace ();
834 if (at_bol
&& gfc_peek_ascii_char () == ';')
836 gfc_error_now ("Semicolon at %C needs to be preceded by "
838 gfc_next_ascii_char (); /* Eat up the semicolon. */
842 if (gfc_match_eos () == MATCH_YES
)
844 gfc_warning_now ("Ignoring statement label in empty statement "
845 "at %L", &label_locus
);
846 gfc_free_st_label (gfc_statement_label
);
847 gfc_statement_label
= NULL
;
854 /* Comments have already been skipped by the time we get here,
855 except for GCC attributes and OpenMP/OpenACC directives. */
857 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
858 c
= gfc_peek_ascii_char ();
864 c
= gfc_next_ascii_char ();
865 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
866 gcc_assert (c
== "gcc$"[i
]);
868 gfc_gobble_whitespace ();
869 return decode_gcc_attribute ();
875 /* Since both OpenMP and OpenACC directives starts with
876 !$ character sequence, we must check all flags combinations */
877 if (gfc_option
.gfc_flag_openmp
&& !gfc_option
.gfc_flag_openacc
)
879 verify_token_free ("$omp", 4, last_was_use_stmt
);
880 return decode_omp_directive ();
882 else if (gfc_option
.gfc_flag_openmp
&& gfc_option
.gfc_flag_openacc
)
884 gfc_next_ascii_char (); /* Eat up dollar character */
885 c
= gfc_peek_ascii_char ();
889 verify_token_free ("omp", 3, last_was_use_stmt
);
890 return decode_omp_directive ();
894 verify_token_free ("acc", 3, last_was_use_stmt
);
895 return decode_oacc_directive ();
898 else if (gfc_option
.gfc_flag_openacc
)
900 verify_token_free ("$acc", 4, last_was_use_stmt
);
901 return decode_oacc_directive ();
907 if (at_bol
&& c
== ';')
909 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
910 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
912 gfc_next_ascii_char (); /* Eat up the semicolon. */
916 return decode_statement ();
919 /* Assert next length characters to be equal to token in fixed form. */
922 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
925 char c
= gfc_next_char_literal (NONSTRING
);
927 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
928 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
930 if (c
!= ' ' && c
!= '0')
932 gfc_buffer_error (0);
933 gfc_error ("Bad continuation line at %C");
936 if (last_was_use_stmt
)
942 /* Get the next statement in fixed-form source. */
947 int label
, digit_flag
, i
;
952 return decode_statement ();
954 /* Skip past the current label field, parsing a statement label if
955 one is there. This is a weird number parser, since the number is
956 contained within five columns and can have any kind of embedded
957 spaces. We also check for characters that make the rest of the
963 for (i
= 0; i
< 5; i
++)
965 c
= gfc_next_char_literal (NONSTRING
);
982 label
= label
* 10 + ((unsigned char) c
- '0');
983 label_locus
= gfc_current_locus
;
987 /* Comments have already been skipped by the time we get
988 here, except for GCC attributes and OpenMP directives. */
991 c
= gfc_next_char_literal (NONSTRING
);
993 if (TOLOWER (c
) == 'g')
995 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
996 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
998 return decode_gcc_attribute ();
1002 if (gfc_option
.gfc_flag_openmp
&& !gfc_option
.gfc_flag_openacc
)
1004 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1006 return decode_omp_directive ();
1008 else if (gfc_option
.gfc_flag_openmp
1009 && gfc_option
.gfc_flag_openacc
)
1011 c
= gfc_next_char_literal(NONSTRING
);
1012 if (c
== 'o' || c
== 'O')
1014 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1016 return decode_omp_directive ();
1018 else if (c
== 'a' || c
== 'A')
1020 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1022 return decode_oacc_directive ();
1025 else if (gfc_option
.gfc_flag_openacc
)
1027 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1029 return decode_oacc_directive ();
1034 /* Comments have already been skipped by the time we get
1035 here so don't bother checking for them. */
1038 gfc_buffer_error (0);
1039 gfc_error ("Non-numeric character in statement label at %C");
1047 gfc_warning_now ("Zero is not a valid statement label at %C");
1050 /* We've found a valid statement label. */
1051 gfc_statement_label
= gfc_get_st_label (label
);
1055 /* Since this line starts a statement, it cannot be a continuation
1056 of a previous statement. If we see something here besides a
1057 space or zero, it must be a bad continuation line. */
1059 c
= gfc_next_char_literal (NONSTRING
);
1063 if (c
!= ' ' && c
!= '0')
1065 gfc_buffer_error (0);
1066 gfc_error ("Bad continuation line at %C");
1070 /* Now that we've taken care of the statement label columns, we have
1071 to make sure that the first nonblank character is not a '!'. If
1072 it is, the rest of the line is a comment. */
1076 loc
= gfc_current_locus
;
1077 c
= gfc_next_char_literal (NONSTRING
);
1079 while (gfc_is_whitespace (c
));
1083 gfc_current_locus
= loc
;
1088 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1089 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1090 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1095 if (gfc_match_eos () == MATCH_YES
)
1098 /* At this point, we've got a nonblank statement to parse. */
1099 return decode_statement ();
1103 gfc_warning_now ("Ignoring statement label in empty statement at %L",
1106 gfc_current_locus
.lb
->truncated
= 0;
1107 gfc_advance_line ();
1112 /* Return the next non-ST_NONE statement to the caller. We also worry
1113 about including files and the ends of include files at this stage. */
1115 static gfc_statement
1116 next_statement (void)
1121 gfc_enforce_clean_symbol_state ();
1123 gfc_new_block
= NULL
;
1125 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1126 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1129 gfc_statement_label
= NULL
;
1130 gfc_buffer_error (1);
1133 gfc_advance_line ();
1135 gfc_skip_comments ();
1143 if (gfc_define_undef_line ())
1146 old_locus
= gfc_current_locus
;
1148 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1154 gfc_buffer_error (0);
1156 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1158 gfc_free_st_label (gfc_statement_label
);
1159 gfc_statement_label
= NULL
;
1160 gfc_current_locus
= old_locus
;
1164 check_statement_label (st
);
1170 /****************************** Parser ***********************************/
1172 /* The parser subroutines are of type 'try' that fail if the file ends
1175 /* Macros that expand to case-labels for various classes of
1176 statements. Start with executable statements that directly do
1179 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1180 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1181 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1182 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1183 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1184 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1185 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1186 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1187 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1188 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1189 case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
1190 case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1191 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1192 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1194 /* Statements that mark other executable statements. */
1196 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1197 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1198 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1199 case ST_OMP_PARALLEL: \
1200 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1201 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1202 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1203 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1204 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1205 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_CRITICAL: \
1206 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1207 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1209 /* Declaration statements */
1211 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1212 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1213 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1214 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD
1216 /* Block end statements. Errors associated with interchanging these
1217 are detected in gfc_match_end(). */
1219 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1220 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1221 case ST_END_BLOCK: case ST_END_ASSOCIATE
1224 /* Push a new state onto the stack. */
1227 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1229 p
->state
= new_state
;
1230 p
->previous
= gfc_state_stack
;
1232 p
->head
= p
->tail
= NULL
;
1233 p
->do_variable
= NULL
;
1234 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1235 p
->ext
.oacc_declare_clauses
= NULL
;
1237 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1238 construct statement was accepted right before pushing the state. Thus,
1239 the construct's gfc_code is available as tail of the parent state. */
1240 gcc_assert (gfc_state_stack
);
1241 p
->construct
= gfc_state_stack
->tail
;
1243 gfc_state_stack
= p
;
1247 /* Pop the current state. */
1251 gfc_state_stack
= gfc_state_stack
->previous
;
1255 /* Try to find the given state in the state stack. */
1258 gfc_find_state (gfc_compile_state state
)
1262 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1263 if (p
->state
== state
)
1266 return (p
== NULL
) ? false : true;
1270 /* Starts a new level in the statement list. */
1273 new_level (gfc_code
*q
)
1277 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1279 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1285 /* Add the current new_st code structure and adds it to the current
1286 program unit. As a side-effect, it zeroes the new_st. */
1289 add_statement (void)
1293 p
= XCNEW (gfc_code
);
1296 p
->loc
= gfc_current_locus
;
1298 if (gfc_state_stack
->head
== NULL
)
1299 gfc_state_stack
->head
= p
;
1301 gfc_state_stack
->tail
->next
= p
;
1303 while (p
->next
!= NULL
)
1306 gfc_state_stack
->tail
= p
;
1308 gfc_clear_new_st ();
1314 /* Frees everything associated with the current statement. */
1317 undo_new_statement (void)
1319 gfc_free_statements (new_st
.block
);
1320 gfc_free_statements (new_st
.next
);
1321 gfc_free_statement (&new_st
);
1322 gfc_clear_new_st ();
1326 /* If the current statement has a statement label, make sure that it
1327 is allowed to, or should have one. */
1330 check_statement_label (gfc_statement st
)
1334 if (gfc_statement_label
== NULL
)
1336 if (st
== ST_FORMAT
)
1337 gfc_error ("FORMAT statement at %L does not have a statement label",
1344 case ST_END_PROGRAM
:
1345 case ST_END_FUNCTION
:
1346 case ST_END_SUBROUTINE
:
1350 case ST_END_CRITICAL
:
1352 case ST_END_ASSOCIATE
:
1355 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1356 type
= ST_LABEL_DO_TARGET
;
1358 type
= ST_LABEL_TARGET
;
1362 type
= ST_LABEL_FORMAT
;
1365 /* Statement labels are not restricted from appearing on a
1366 particular line. However, there are plenty of situations
1367 where the resulting label can't be referenced. */
1370 type
= ST_LABEL_BAD_TARGET
;
1374 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1376 new_st
.here
= gfc_statement_label
;
1380 /* Figures out what the enclosing program unit is. This will be a
1381 function, subroutine, program, block data or module. */
1384 gfc_enclosing_unit (gfc_compile_state
* result
)
1388 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1389 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1390 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1391 || p
->state
== COMP_PROGRAM
)
1400 *result
= COMP_PROGRAM
;
1405 /* Translate a statement enum to a string. */
1408 gfc_ascii_statement (gfc_statement st
)
1414 case ST_ARITHMETIC_IF
:
1415 p
= _("arithmetic IF");
1424 p
= _("attribute declaration");
1460 p
= _("data declaration");
1468 case ST_DERIVED_DECL
:
1469 p
= _("derived type declaration");
1483 case ST_END_ASSOCIATE
:
1484 p
= "END ASSOCIATE";
1489 case ST_END_BLOCK_DATA
:
1490 p
= "END BLOCK DATA";
1492 case ST_END_CRITICAL
:
1504 case ST_END_FUNCTION
:
1510 case ST_END_INTERFACE
:
1511 p
= "END INTERFACE";
1516 case ST_END_PROGRAM
:
1522 case ST_END_SUBROUTINE
:
1523 p
= "END SUBROUTINE";
1534 case ST_EQUIVALENCE
:
1546 case ST_FORALL_BLOCK
: /* Fall through */
1568 case ST_IMPLICIT_NONE
:
1569 p
= "IMPLICIT NONE";
1571 case ST_IMPLIED_ENDDO
:
1572 p
= _("implied END DO");
1601 case ST_MODULE_PROC
:
1602 p
= "MODULE PROCEDURE";
1634 case ST_SYNC_IMAGES
:
1637 case ST_SYNC_MEMORY
:
1652 case ST_WHERE_BLOCK
: /* Fall through */
1663 p
= _("assignment");
1665 case ST_POINTER_ASSIGNMENT
:
1666 p
= _("pointer assignment");
1668 case ST_SELECT_CASE
:
1671 case ST_SELECT_TYPE
:
1686 case ST_STATEMENT_FUNCTION
:
1687 p
= "STATEMENT FUNCTION";
1689 case ST_LABEL_ASSIGNMENT
:
1690 p
= "LABEL ASSIGNMENT";
1693 p
= "ENUM DEFINITION";
1696 p
= "ENUMERATOR DEFINITION";
1701 case ST_OACC_PARALLEL_LOOP
:
1702 p
= "!$ACC PARALLEL LOOP";
1704 case ST_OACC_END_PARALLEL_LOOP
:
1705 p
= "!$ACC END PARALLEL LOOP";
1707 case ST_OACC_PARALLEL
:
1708 p
= "!$ACC PARALLEL";
1710 case ST_OACC_END_PARALLEL
:
1711 p
= "!$ACC END PARALLEL";
1713 case ST_OACC_KERNELS
:
1714 p
= "!$ACC KERNELS";
1716 case ST_OACC_END_KERNELS
:
1717 p
= "!$ACC END KERNELS";
1719 case ST_OACC_KERNELS_LOOP
:
1720 p
= "!$ACC KERNELS LOOP";
1722 case ST_OACC_END_KERNELS_LOOP
:
1723 p
= "!$ACC END KERNELS LOOP";
1728 case ST_OACC_END_DATA
:
1729 p
= "!$ACC END DATA";
1731 case ST_OACC_HOST_DATA
:
1732 p
= "!$ACC HOST_DATA";
1734 case ST_OACC_END_HOST_DATA
:
1735 p
= "!$ACC END HOST_DATA";
1740 case ST_OACC_END_LOOP
:
1741 p
= "!$ACC END LOOP";
1743 case ST_OACC_DECLARE
:
1744 p
= "!$ACC DECLARE";
1746 case ST_OACC_UPDATE
:
1755 case ST_OACC_ENTER_DATA
:
1756 p
= "!$ACC ENTER DATA";
1758 case ST_OACC_EXIT_DATA
:
1759 p
= "!$ACC EXIT DATA";
1764 case ST_OMP_BARRIER
:
1765 p
= "!$OMP BARRIER";
1770 case ST_OMP_CANCELLATION_POINT
:
1771 p
= "!$OMP CANCELLATION POINT";
1773 case ST_OMP_CRITICAL
:
1774 p
= "!$OMP CRITICAL";
1776 case ST_OMP_DECLARE_SIMD
:
1777 p
= "!$OMP DECLARE SIMD";
1782 case ST_OMP_DO_SIMD
:
1783 p
= "!$OMP DO SIMD";
1785 case ST_OMP_END_ATOMIC
:
1786 p
= "!$OMP END ATOMIC";
1788 case ST_OMP_END_CRITICAL
:
1789 p
= "!$OMP END CRITICAL";
1794 case ST_OMP_END_DO_SIMD
:
1795 p
= "!$OMP END DO SIMD";
1797 case ST_OMP_END_SIMD
:
1798 p
= "!$OMP END SIMD";
1800 case ST_OMP_END_MASTER
:
1801 p
= "!$OMP END MASTER";
1803 case ST_OMP_END_ORDERED
:
1804 p
= "!$OMP END ORDERED";
1806 case ST_OMP_END_PARALLEL
:
1807 p
= "!$OMP END PARALLEL";
1809 case ST_OMP_END_PARALLEL_DO
:
1810 p
= "!$OMP END PARALLEL DO";
1812 case ST_OMP_END_PARALLEL_DO_SIMD
:
1813 p
= "!$OMP END PARALLEL DO SIMD";
1815 case ST_OMP_END_PARALLEL_SECTIONS
:
1816 p
= "!$OMP END PARALLEL SECTIONS";
1818 case ST_OMP_END_PARALLEL_WORKSHARE
:
1819 p
= "!$OMP END PARALLEL WORKSHARE";
1821 case ST_OMP_END_SECTIONS
:
1822 p
= "!$OMP END SECTIONS";
1824 case ST_OMP_END_SINGLE
:
1825 p
= "!$OMP END SINGLE";
1827 case ST_OMP_END_TASK
:
1828 p
= "!$OMP END TASK";
1830 case ST_OMP_END_TASKGROUP
:
1831 p
= "!$OMP END TASKGROUP";
1833 case ST_OMP_END_WORKSHARE
:
1834 p
= "!$OMP END WORKSHARE";
1842 case ST_OMP_ORDERED
:
1843 p
= "!$OMP ORDERED";
1845 case ST_OMP_PARALLEL
:
1846 p
= "!$OMP PARALLEL";
1848 case ST_OMP_PARALLEL_DO
:
1849 p
= "!$OMP PARALLEL DO";
1851 case ST_OMP_PARALLEL_DO_SIMD
:
1852 p
= "!$OMP PARALLEL DO SIMD";
1854 case ST_OMP_PARALLEL_SECTIONS
:
1855 p
= "!$OMP PARALLEL SECTIONS";
1857 case ST_OMP_PARALLEL_WORKSHARE
:
1858 p
= "!$OMP PARALLEL WORKSHARE";
1860 case ST_OMP_SECTIONS
:
1861 p
= "!$OMP SECTIONS";
1863 case ST_OMP_SECTION
:
1864 p
= "!$OMP SECTION";
1875 case ST_OMP_TASKGROUP
:
1876 p
= "!$OMP TASKGROUP";
1878 case ST_OMP_TASKWAIT
:
1879 p
= "!$OMP TASKWAIT";
1881 case ST_OMP_TASKYIELD
:
1882 p
= "!$OMP TASKYIELD";
1884 case ST_OMP_THREADPRIVATE
:
1885 p
= "!$OMP THREADPRIVATE";
1887 case ST_OMP_WORKSHARE
:
1888 p
= "!$OMP WORKSHARE";
1891 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1898 /* Create a symbol for the main program and assign it to ns->proc_name. */
1901 main_program_symbol (gfc_namespace
*ns
, const char *name
)
1903 gfc_symbol
*main_program
;
1904 symbol_attribute attr
;
1906 gfc_get_symbol (name
, ns
, &main_program
);
1907 gfc_clear_attr (&attr
);
1908 attr
.flavor
= FL_PROGRAM
;
1909 attr
.proc
= PROC_UNKNOWN
;
1910 attr
.subroutine
= 1;
1911 attr
.access
= ACCESS_PUBLIC
;
1912 attr
.is_main_program
= 1;
1913 main_program
->attr
= attr
;
1914 main_program
->declared_at
= gfc_current_locus
;
1915 ns
->proc_name
= main_program
;
1916 gfc_commit_symbols ();
1920 /* Do whatever is necessary to accept the last statement. */
1923 accept_statement (gfc_statement st
)
1927 case ST_IMPLICIT_NONE
:
1928 gfc_set_implicit_none ();
1937 gfc_current_ns
->proc_name
= gfc_new_block
;
1940 /* If the statement is the end of a block, lay down a special code
1941 that allows a branch to the end of the block from within the
1942 construct. IF and SELECT are treated differently from DO
1943 (where EXEC_NOP is added inside the loop) for two
1945 1. END DO has a meaning in the sense that after a GOTO to
1946 it, the loop counter must be increased.
1947 2. IF blocks and SELECT blocks can consist of multiple
1948 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1949 Putting the label before the END IF would make the jump
1950 from, say, the ELSE IF block to the END IF illegal. */
1954 case ST_END_CRITICAL
:
1955 if (gfc_statement_label
!= NULL
)
1957 new_st
.op
= EXEC_END_NESTED_BLOCK
;
1962 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
1963 one parallel block. Thus, we add the special code to the nested block
1964 itself, instead of the parent one. */
1966 case ST_END_ASSOCIATE
:
1967 if (gfc_statement_label
!= NULL
)
1969 new_st
.op
= EXEC_END_BLOCK
;
1974 /* The end-of-program unit statements do not get the special
1975 marker and require a statement of some sort if they are a
1978 case ST_END_PROGRAM
:
1979 case ST_END_FUNCTION
:
1980 case ST_END_SUBROUTINE
:
1981 if (gfc_statement_label
!= NULL
)
1983 new_st
.op
= EXEC_RETURN
;
1988 new_st
.op
= EXEC_END_PROCEDURE
;
2004 gfc_commit_symbols ();
2005 gfc_warning_check ();
2006 gfc_clear_new_st ();
2010 /* Undo anything tentative that has been built for the current
2014 reject_statement (void)
2016 /* Revert to the previous charlen chain. */
2017 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2018 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2020 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2021 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2023 gfc_new_block
= NULL
;
2024 gfc_undo_symbols ();
2025 gfc_clear_warning ();
2026 undo_new_statement ();
2030 /* Generic complaint about an out of order statement. We also do
2031 whatever is necessary to clean up. */
2034 unexpected_statement (gfc_statement st
)
2036 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2038 reject_statement ();
2042 /* Given the next statement seen by the matcher, make sure that it is
2043 in proper order with the last. This subroutine is initialized by
2044 calling it with an argument of ST_NONE. If there is a problem, we
2045 issue an error and return false. Otherwise we return true.
2047 Individual parsers need to verify that the statements seen are
2048 valid before calling here, i.e., ENTRY statements are not allowed in
2049 INTERFACE blocks. The following diagram is taken from the standard:
2051 +---------------------------------------+
2052 | program subroutine function module |
2053 +---------------------------------------+
2055 +---------------------------------------+
2057 +---------------------------------------+
2059 | +-----------+------------------+
2060 | | parameter | implicit |
2061 | +-----------+------------------+
2062 | format | | derived type |
2063 | entry | parameter | interface |
2064 | | data | specification |
2065 | | | statement func |
2066 | +-----------+------------------+
2067 | | data | executable |
2068 +--------+-----------+------------------+
2070 +---------------------------------------+
2071 | internal module/subprogram |
2072 +---------------------------------------+
2074 +---------------------------------------+
2083 ORDER_IMPLICIT_NONE
,
2091 enum state_order state
;
2092 gfc_statement last_statement
;
2098 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2104 p
->state
= ORDER_START
;
2108 if (p
->state
> ORDER_USE
)
2110 p
->state
= ORDER_USE
;
2114 if (p
->state
> ORDER_IMPORT
)
2116 p
->state
= ORDER_IMPORT
;
2119 case ST_IMPLICIT_NONE
:
2120 if (p
->state
> ORDER_IMPLICIT_NONE
)
2123 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2124 statement disqualifies a USE but not an IMPLICIT NONE.
2125 Duplicate IMPLICIT NONEs are caught when the implicit types
2128 p
->state
= ORDER_IMPLICIT_NONE
;
2132 if (p
->state
> ORDER_IMPLICIT
)
2134 p
->state
= ORDER_IMPLICIT
;
2139 if (p
->state
< ORDER_IMPLICIT_NONE
)
2140 p
->state
= ORDER_IMPLICIT_NONE
;
2144 if (p
->state
>= ORDER_EXEC
)
2146 if (p
->state
< ORDER_IMPLICIT
)
2147 p
->state
= ORDER_IMPLICIT
;
2151 if (p
->state
< ORDER_SPEC
)
2152 p
->state
= ORDER_SPEC
;
2157 case ST_DERIVED_DECL
:
2158 case ST_OACC_DECLARE
:
2160 if (p
->state
>= ORDER_EXEC
)
2162 if (p
->state
< ORDER_SPEC
)
2163 p
->state
= ORDER_SPEC
;
2168 if (p
->state
< ORDER_EXEC
)
2169 p
->state
= ORDER_EXEC
;
2173 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
2174 gfc_ascii_statement (st
));
2177 /* All is well, record the statement in case we need it next time. */
2178 p
->where
= gfc_current_locus
;
2179 p
->last_statement
= st
;
2184 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2185 gfc_ascii_statement (st
),
2186 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2192 /* Handle an unexpected end of file. This is a show-stopper... */
2194 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2197 unexpected_eof (void)
2201 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
2203 /* Memory cleanup. Move to "second to last". */
2204 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2207 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2210 longjmp (eof_buf
, 1);
2214 /* Parse the CONTAINS section of a derived type definition. */
2216 gfc_access gfc_typebound_default_access
;
2219 parse_derived_contains (void)
2222 bool seen_private
= false;
2223 bool seen_comps
= false;
2224 bool error_flag
= false;
2227 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2228 gcc_assert (gfc_current_block ());
2230 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2232 if (gfc_current_block ()->attr
.sequence
)
2233 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
2234 " section at %C", gfc_current_block ()->name
);
2235 if (gfc_current_block ()->attr
.is_bind_c
)
2236 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
2237 " section at %C", gfc_current_block ()->name
);
2239 accept_statement (ST_CONTAINS
);
2240 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2242 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2248 st
= next_statement ();
2256 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2260 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2263 accept_statement (ST_PROCEDURE
);
2268 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2271 accept_statement (ST_GENERIC
);
2276 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2280 accept_statement (ST_FINAL
);
2288 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2289 "at %C with empty CONTAINS section")))
2292 /* ST_END_TYPE is accepted by parse_derived after return. */
2296 if (!gfc_find_state (COMP_MODULE
))
2298 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2305 gfc_error ("PRIVATE statement at %C must precede procedure"
2312 gfc_error ("Duplicate PRIVATE statement at %C");
2316 accept_statement (ST_PRIVATE
);
2317 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2318 seen_private
= true;
2322 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2326 gfc_error ("Already inside a CONTAINS block at %C");
2330 unexpected_statement (st
);
2338 reject_statement ();
2342 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2348 /* Parse a derived type. */
2351 parse_derived (void)
2353 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2357 gfc_component
*c
, *lock_comp
= NULL
;
2359 accept_statement (ST_DERIVED_DECL
);
2360 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2362 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2369 while (compiling_type
)
2371 st
= next_statement ();
2379 accept_statement (st
);
2384 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2391 if (!seen_component
)
2392 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2393 "definition at %C without components");
2395 accept_statement (ST_END_TYPE
);
2399 if (!gfc_find_state (COMP_MODULE
))
2401 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2408 gfc_error ("PRIVATE statement at %C must precede "
2409 "structure components");
2414 gfc_error ("Duplicate PRIVATE statement at %C");
2416 s
.sym
->component_access
= ACCESS_PRIVATE
;
2418 accept_statement (ST_PRIVATE
);
2425 gfc_error ("SEQUENCE statement at %C must precede "
2426 "structure components");
2430 if (gfc_current_block ()->attr
.sequence
)
2431 gfc_warning ("SEQUENCE attribute at %C already specified in "
2436 gfc_error ("Duplicate SEQUENCE statement at %C");
2440 gfc_add_sequence (&gfc_current_block ()->attr
,
2441 gfc_current_block ()->name
, NULL
);
2445 gfc_notify_std (GFC_STD_F2003
,
2446 "CONTAINS block in derived type"
2447 " definition at %C");
2449 accept_statement (ST_CONTAINS
);
2450 parse_derived_contains ();
2454 unexpected_statement (st
);
2459 /* need to verify that all fields of the derived type are
2460 * interoperable with C if the type is declared to be bind(c)
2462 sym
= gfc_current_block ();
2463 for (c
= sym
->components
; c
; c
= c
->next
)
2465 bool coarray
, lock_type
, allocatable
, pointer
;
2466 coarray
= lock_type
= allocatable
= pointer
= false;
2468 /* Look for allocatable components. */
2469 if (c
->attr
.allocatable
2470 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2471 && CLASS_DATA (c
)->attr
.allocatable
)
2472 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2473 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2476 sym
->attr
.alloc_comp
= 1;
2479 /* Look for pointer components. */
2481 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2482 && CLASS_DATA (c
)->attr
.class_pointer
)
2483 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2486 sym
->attr
.pointer_comp
= 1;
2489 /* Look for procedure pointer components. */
2490 if (c
->attr
.proc_pointer
2491 || (c
->ts
.type
== BT_DERIVED
2492 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2493 sym
->attr
.proc_pointer_comp
= 1;
2495 /* Looking for coarray components. */
2496 if (c
->attr
.codimension
2497 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2498 && CLASS_DATA (c
)->attr
.codimension
))
2501 sym
->attr
.coarray_comp
= 1;
2504 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2505 && !c
->attr
.pointer
)
2508 sym
->attr
.coarray_comp
= 1;
2511 /* Looking for lock_type components. */
2512 if ((c
->ts
.type
== BT_DERIVED
2513 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2514 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2515 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2516 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2517 == INTMOD_ISO_FORTRAN_ENV
2518 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2519 == ISOFORTRAN_LOCK_TYPE
)
2520 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2521 && !allocatable
&& !pointer
))
2525 sym
->attr
.lock_comp
= 1;
2528 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2529 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2530 unless there are nondirect [allocatable or pointer] components
2531 involved (cf. 1.3.33.1 and 1.3.33.3). */
2533 if (pointer
&& !coarray
&& lock_type
)
2534 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2535 "codimension or be a subcomponent of a coarray, "
2536 "which is not possible as the component has the "
2537 "pointer attribute", c
->name
, &c
->loc
);
2538 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2539 && c
->ts
.u
.derived
->attr
.lock_comp
)
2540 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2541 "of type LOCK_TYPE, which must have a codimension or be a "
2542 "subcomponent of a coarray", c
->name
, &c
->loc
);
2544 if (lock_type
&& allocatable
&& !coarray
)
2545 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2546 "a codimension", c
->name
, &c
->loc
);
2547 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2548 && c
->ts
.u
.derived
->attr
.lock_comp
)
2549 gfc_error ("Allocatable component %s at %L must have a codimension as "
2550 "it has a noncoarray subcomponent of type LOCK_TYPE",
2553 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2554 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2555 "subcomponent of type LOCK_TYPE must have a codimension or "
2556 "be a subcomponent of a coarray. (Variables of type %s may "
2557 "not have a codimension as already a coarray "
2558 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2560 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2561 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2562 "subcomponent of type LOCK_TYPE must have a codimension or "
2563 "be a subcomponent of a coarray. (Variables of type %s may "
2564 "not have a codimension as %s at %L has a codimension or a "
2565 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2566 sym
->name
, c
->name
, &c
->loc
);
2568 /* Look for private components. */
2569 if (sym
->component_access
== ACCESS_PRIVATE
2570 || c
->attr
.access
== ACCESS_PRIVATE
2571 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2572 sym
->attr
.private_comp
= 1;
2575 if (!seen_component
)
2576 sym
->attr
.zero_comp
= 1;
2582 /* Parse an ENUM. */
2590 int seen_enumerator
= 0;
2592 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2596 while (compiling_enum
)
2598 st
= next_statement ();
2606 seen_enumerator
= 1;
2607 accept_statement (st
);
2612 if (!seen_enumerator
)
2613 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2614 accept_statement (st
);
2618 gfc_free_enum_history ();
2619 unexpected_statement (st
);
2627 /* Parse an interface. We must be able to deal with the possibility
2628 of recursive interfaces. The parse_spec() subroutine is mutually
2629 recursive with parse_interface(). */
2631 static gfc_statement
parse_spec (gfc_statement
);
2634 parse_interface (void)
2636 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2637 gfc_symbol
*prog_unit
, *sym
;
2638 gfc_interface_info save
;
2639 gfc_state_data s1
, s2
;
2642 accept_statement (ST_INTERFACE
);
2644 current_interface
.ns
= gfc_current_ns
;
2645 save
= current_interface
;
2647 sym
= (current_interface
.type
== INTERFACE_GENERIC
2648 || current_interface
.type
== INTERFACE_USER_OP
)
2649 ? gfc_new_block
: NULL
;
2651 push_state (&s1
, COMP_INTERFACE
, sym
);
2652 current_state
= COMP_NONE
;
2655 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2657 st
= next_statement ();
2665 if (st
== ST_SUBROUTINE
)
2666 new_state
= COMP_SUBROUTINE
;
2667 else if (st
== ST_FUNCTION
)
2668 new_state
= COMP_FUNCTION
;
2669 if (gfc_new_block
->attr
.pointer
)
2671 gfc_new_block
->attr
.pointer
= 0;
2672 gfc_new_block
->attr
.proc_pointer
= 1;
2674 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2675 gfc_new_block
->formal
, NULL
))
2677 reject_statement ();
2678 gfc_free_namespace (gfc_current_ns
);
2684 case ST_MODULE_PROC
: /* The module procedure matcher makes
2685 sure the context is correct. */
2686 accept_statement (st
);
2687 gfc_free_namespace (gfc_current_ns
);
2690 case ST_END_INTERFACE
:
2691 gfc_free_namespace (gfc_current_ns
);
2692 gfc_current_ns
= current_interface
.ns
;
2696 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2697 gfc_ascii_statement (st
));
2698 reject_statement ();
2699 gfc_free_namespace (gfc_current_ns
);
2704 /* Make sure that the generic name has the right attribute. */
2705 if (current_interface
.type
== INTERFACE_GENERIC
2706 && current_state
== COMP_NONE
)
2708 if (new_state
== COMP_FUNCTION
&& sym
)
2709 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2710 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2711 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2713 current_state
= new_state
;
2716 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2718 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2719 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2720 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2721 "cannot be the same as an intrinsic type",
2722 gfc_new_block
->name
);
2725 push_state (&s2
, new_state
, gfc_new_block
);
2726 accept_statement (st
);
2727 prog_unit
= gfc_new_block
;
2728 prog_unit
->formal_ns
= gfc_current_ns
;
2729 if (prog_unit
== prog_unit
->formal_ns
->proc_name
2730 && prog_unit
->ns
!= prog_unit
->formal_ns
)
2734 /* Read data declaration statements. */
2735 st
= parse_spec (ST_NONE
);
2737 /* Since the interface block does not permit an IMPLICIT statement,
2738 the default type for the function or the result must be taken
2739 from the formal namespace. */
2740 if (new_state
== COMP_FUNCTION
)
2742 if (prog_unit
->result
== prog_unit
2743 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2744 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2745 else if (prog_unit
->result
!= prog_unit
2746 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
2747 gfc_set_default_type (prog_unit
->result
, 1,
2748 prog_unit
->formal_ns
);
2751 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
2753 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2754 gfc_ascii_statement (st
));
2755 reject_statement ();
2759 /* Add EXTERNAL attribute to function or subroutine. */
2760 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
2761 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
2763 current_interface
= save
;
2764 gfc_add_interface (prog_unit
);
2767 if (current_interface
.ns
2768 && current_interface
.ns
->proc_name
2769 && strcmp (current_interface
.ns
->proc_name
->name
,
2770 prog_unit
->name
) == 0)
2771 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2772 "enclosing procedure", prog_unit
->name
,
2773 ¤t_interface
.ns
->proc_name
->declared_at
);
2782 /* Associate function characteristics by going back to the function
2783 declaration and rematching the prefix. */
2786 match_deferred_characteristics (gfc_typespec
* ts
)
2789 match m
= MATCH_ERROR
;
2790 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2792 loc
= gfc_current_locus
;
2794 gfc_current_locus
= gfc_current_block ()->declared_at
;
2797 gfc_buffer_error (1);
2798 m
= gfc_match_prefix (ts
);
2799 gfc_buffer_error (0);
2801 if (ts
->type
== BT_DERIVED
)
2809 /* Only permit one go at the characteristic association. */
2813 /* Set the function locus correctly. If we have not found the
2814 function name, there is an error. */
2816 && gfc_match ("function% %n", name
) == MATCH_YES
2817 && strcmp (name
, gfc_current_block ()->name
) == 0)
2819 gfc_current_block ()->declared_at
= gfc_current_locus
;
2820 gfc_commit_symbols ();
2825 gfc_undo_symbols ();
2828 gfc_current_locus
=loc
;
2833 /* Check specification-expressions in the function result of the currently
2834 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2835 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2836 scope are not yet parsed so this has to be delayed up to parse_spec. */
2839 check_function_result_typed (void)
2841 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
2843 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
2844 gcc_assert (ts
->type
!= BT_UNKNOWN
);
2846 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
2847 /* TODO: Extend when KIND type parameters are implemented. */
2848 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
2849 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
2853 /* Parse a set of specification statements. Returns the statement
2854 that doesn't fit. */
2856 static gfc_statement
2857 parse_spec (gfc_statement st
)
2860 bool function_result_typed
= false;
2861 bool bad_characteristic
= false;
2864 verify_st_order (&ss
, ST_NONE
, false);
2866 st
= next_statement ();
2868 /* If we are not inside a function or don't have a result specified so far,
2869 do nothing special about it. */
2870 if (gfc_current_state () != COMP_FUNCTION
)
2871 function_result_typed
= true;
2874 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
2877 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
2878 function_result_typed
= true;
2883 /* If we're inside a BLOCK construct, some statements are disallowed.
2884 Check this here. Attribute declaration statements like INTENT, OPTIONAL
2885 or VALUE are also disallowed, but they don't have a particular ST_*
2886 key so we have to check for them individually in their matcher routine. */
2887 if (gfc_current_state () == COMP_BLOCK
)
2891 case ST_IMPLICIT_NONE
:
2894 case ST_EQUIVALENCE
:
2895 case ST_STATEMENT_FUNCTION
:
2896 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2897 gfc_ascii_statement (st
));
2898 reject_statement ();
2904 else if (gfc_current_state () == COMP_BLOCK_DATA
)
2905 /* Fortran 2008, C1116. */
2912 case ST_END_BLOCK_DATA
:
2914 case ST_EQUIVALENCE
:
2917 case ST_IMPLICIT_NONE
:
2918 case ST_DERIVED_DECL
:
2926 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
2927 gfc_ascii_statement (st
));
2928 reject_statement ();
2932 /* If we find a statement that can not be followed by an IMPLICIT statement
2933 (and thus we can expect to see none any further), type the function result
2934 if it has not yet been typed. Be careful not to give the END statement
2935 to verify_st_order! */
2936 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
2938 bool verify_now
= false;
2940 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
2945 verify_st_order (&dummyss
, ST_NONE
, false);
2946 verify_st_order (&dummyss
, st
, false);
2948 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
2954 check_function_result_typed ();
2955 function_result_typed
= true;
2964 case ST_IMPLICIT_NONE
:
2966 if (!function_result_typed
)
2968 check_function_result_typed ();
2969 function_result_typed
= true;
2975 case ST_DATA
: /* Not allowed in interfaces */
2976 if (gfc_current_state () == COMP_INTERFACE
)
2986 case ST_DERIVED_DECL
:
2989 if (!verify_st_order (&ss
, st
, false))
2991 reject_statement ();
2992 st
= next_statement ();
3002 case ST_DERIVED_DECL
:
3008 if (gfc_current_state () != COMP_MODULE
)
3010 gfc_error ("%s statement must appear in a MODULE",
3011 gfc_ascii_statement (st
));
3012 reject_statement ();
3016 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3018 gfc_error ("%s statement at %C follows another accessibility "
3019 "specification", gfc_ascii_statement (st
));
3020 reject_statement ();
3024 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3025 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3029 case ST_STATEMENT_FUNCTION
:
3030 if (gfc_current_state () == COMP_MODULE
)
3032 unexpected_statement (st
);
3040 accept_statement (st
);
3041 st
= next_statement ();
3045 accept_statement (st
);
3047 st
= next_statement ();
3050 case ST_GET_FCN_CHARACTERISTICS
:
3051 /* This statement triggers the association of a function's result
3053 ts
= &gfc_current_block ()->result
->ts
;
3054 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3055 bad_characteristic
= true;
3057 st
= next_statement ();
3060 case ST_OACC_DECLARE
:
3061 if (!verify_st_order(&ss
, st
, false))
3063 reject_statement ();
3064 st
= next_statement ();
3067 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3068 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3069 accept_statement (st
);
3070 st
= next_statement ();
3077 /* If match_deferred_characteristics failed, then there is an error. */
3078 if (bad_characteristic
)
3080 ts
= &gfc_current_block ()->result
->ts
;
3081 if (ts
->type
!= BT_DERIVED
)
3082 gfc_error ("Bad kind expression for function '%s' at %L",
3083 gfc_current_block ()->name
,
3084 &gfc_current_block ()->declared_at
);
3086 gfc_error ("The type for function '%s' at %L is not accessible",
3087 gfc_current_block ()->name
,
3088 &gfc_current_block ()->declared_at
);
3090 gfc_current_block ()->ts
.kind
= 0;
3091 /* Keep the derived type; if it's bad, it will be discovered later. */
3092 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3093 ts
->type
= BT_UNKNOWN
;
3100 /* Parse a WHERE block, (not a simple WHERE statement). */
3103 parse_where_block (void)
3105 int seen_empty_else
;
3110 accept_statement (ST_WHERE_BLOCK
);
3111 top
= gfc_state_stack
->tail
;
3113 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3115 d
= add_statement ();
3116 d
->expr1
= top
->expr1
;
3122 seen_empty_else
= 0;
3126 st
= next_statement ();
3132 case ST_WHERE_BLOCK
:
3133 parse_where_block ();
3138 accept_statement (st
);
3142 if (seen_empty_else
)
3144 gfc_error ("ELSEWHERE statement at %C follows previous "
3145 "unmasked ELSEWHERE");
3146 reject_statement ();
3150 if (new_st
.expr1
== NULL
)
3151 seen_empty_else
= 1;
3153 d
= new_level (gfc_state_stack
->head
);
3155 d
->expr1
= new_st
.expr1
;
3157 accept_statement (st
);
3162 accept_statement (st
);
3166 gfc_error ("Unexpected %s statement in WHERE block at %C",
3167 gfc_ascii_statement (st
));
3168 reject_statement ();
3172 while (st
!= ST_END_WHERE
);
3178 /* Parse a FORALL block (not a simple FORALL statement). */
3181 parse_forall_block (void)
3187 accept_statement (ST_FORALL_BLOCK
);
3188 top
= gfc_state_stack
->tail
;
3190 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3192 d
= add_statement ();
3193 d
->op
= EXEC_FORALL
;
3198 st
= next_statement ();
3203 case ST_POINTER_ASSIGNMENT
:
3206 accept_statement (st
);
3209 case ST_WHERE_BLOCK
:
3210 parse_where_block ();
3213 case ST_FORALL_BLOCK
:
3214 parse_forall_block ();
3218 accept_statement (st
);
3225 gfc_error ("Unexpected %s statement in FORALL block at %C",
3226 gfc_ascii_statement (st
));
3228 reject_statement ();
3232 while (st
!= ST_END_FORALL
);
3238 static gfc_statement
parse_executable (gfc_statement
);
3240 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3243 parse_if_block (void)
3252 accept_statement (ST_IF_BLOCK
);
3254 top
= gfc_state_stack
->tail
;
3255 push_state (&s
, COMP_IF
, gfc_new_block
);
3257 new_st
.op
= EXEC_IF
;
3258 d
= add_statement ();
3260 d
->expr1
= top
->expr1
;
3266 st
= parse_executable (ST_NONE
);
3276 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3277 "statement at %L", &else_locus
);
3279 reject_statement ();
3283 d
= new_level (gfc_state_stack
->head
);
3285 d
->expr1
= new_st
.expr1
;
3287 accept_statement (st
);
3294 gfc_error ("Duplicate ELSE statements at %L and %C",
3296 reject_statement ();
3301 else_locus
= gfc_current_locus
;
3303 d
= new_level (gfc_state_stack
->head
);
3306 accept_statement (st
);
3314 unexpected_statement (st
);
3318 while (st
!= ST_ENDIF
);
3321 accept_statement (st
);
3325 /* Parse a SELECT block. */
3328 parse_select_block (void)
3334 accept_statement (ST_SELECT_CASE
);
3336 cp
= gfc_state_stack
->tail
;
3337 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3339 /* Make sure that the next statement is a CASE or END SELECT. */
3342 st
= next_statement ();
3345 if (st
== ST_END_SELECT
)
3347 /* Empty SELECT CASE is OK. */
3348 accept_statement (st
);
3355 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3358 reject_statement ();
3361 /* At this point, we're got a nonempty select block. */
3362 cp
= new_level (cp
);
3365 accept_statement (st
);
3369 st
= parse_executable (ST_NONE
);
3376 cp
= new_level (gfc_state_stack
->head
);
3378 gfc_clear_new_st ();
3380 accept_statement (st
);
3386 /* Can't have an executable statement because of
3387 parse_executable(). */
3389 unexpected_statement (st
);
3393 while (st
!= ST_END_SELECT
);
3396 accept_statement (st
);
3400 /* Pop the current selector from the SELECT TYPE stack. */
3403 select_type_pop (void)
3405 gfc_select_type_stack
*old
= select_type_stack
;
3406 select_type_stack
= old
->prev
;
3411 /* Parse a SELECT TYPE construct (F03:R821). */
3414 parse_select_type_block (void)
3420 accept_statement (ST_SELECT_TYPE
);
3422 cp
= gfc_state_stack
->tail
;
3423 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3425 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3429 st
= next_statement ();
3432 if (st
== ST_END_SELECT
)
3433 /* Empty SELECT CASE is OK. */
3435 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3438 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3439 "following SELECT TYPE at %C");
3441 reject_statement ();
3444 /* At this point, we're got a nonempty select block. */
3445 cp
= new_level (cp
);
3448 accept_statement (st
);
3452 st
= parse_executable (ST_NONE
);
3460 cp
= new_level (gfc_state_stack
->head
);
3462 gfc_clear_new_st ();
3464 accept_statement (st
);
3470 /* Can't have an executable statement because of
3471 parse_executable(). */
3473 unexpected_statement (st
);
3477 while (st
!= ST_END_SELECT
);
3481 accept_statement (st
);
3482 gfc_current_ns
= gfc_current_ns
->parent
;
3487 /* Given a symbol, make sure it is not an iteration variable for a DO
3488 statement. This subroutine is called when the symbol is seen in a
3489 context that causes it to become redefined. If the symbol is an
3490 iterator, we generate an error message and return nonzero. */
3493 gfc_check_do_variable (gfc_symtree
*st
)
3497 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3498 if (s
->do_variable
== st
)
3500 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3501 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3509 /* Checks to see if the current statement label closes an enddo.
3510 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3511 an error) if it incorrectly closes an ENDDO. */
3514 check_do_closure (void)
3518 if (gfc_statement_label
== NULL
)
3521 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3522 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3526 return 0; /* No loops to close */
3528 if (p
->ext
.end_do_label
== gfc_statement_label
)
3530 if (p
== gfc_state_stack
)
3533 gfc_error ("End of nonblock DO statement at %C is within another block");
3537 /* At this point, the label doesn't terminate the innermost loop.
3538 Make sure it doesn't terminate another one. */
3539 for (; p
; p
= p
->previous
)
3540 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3541 && p
->ext
.end_do_label
== gfc_statement_label
)
3543 gfc_error ("End of nonblock DO statement at %C is interwoven "
3544 "with another DO loop");
3552 /* Parse a series of contained program units. */
3554 static void parse_progunit (gfc_statement
);
3557 /* Parse a CRITICAL block. */
3560 parse_critical_block (void)
3563 gfc_state_data s
, *sd
;
3566 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3567 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3568 gfc_error_now ("CRITICAL block inside of OpenMP or OpenACC region at %C");
3570 s
.ext
.end_do_label
= new_st
.label1
;
3572 accept_statement (ST_CRITICAL
);
3573 top
= gfc_state_stack
->tail
;
3575 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3577 d
= add_statement ();
3578 d
->op
= EXEC_CRITICAL
;
3583 st
= parse_executable (ST_NONE
);
3591 case ST_END_CRITICAL
:
3592 if (s
.ext
.end_do_label
!= NULL
3593 && s
.ext
.end_do_label
!= gfc_statement_label
)
3594 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3595 "match CRITICAL label");
3597 if (gfc_statement_label
!= NULL
)
3599 new_st
.op
= EXEC_NOP
;
3605 unexpected_statement (st
);
3609 while (st
!= ST_END_CRITICAL
);
3612 accept_statement (st
);
3616 /* Set up the local namespace for a BLOCK construct. */
3619 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3621 gfc_namespace
* my_ns
;
3622 static int numblock
= 1;
3624 my_ns
= gfc_get_namespace (parent_ns
, 1);
3625 my_ns
->construct_entities
= 1;
3627 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3628 code generation (so it must not be NULL).
3629 We set its recursive argument if our container procedure is recursive, so
3630 that local variables are accordingly placed on the stack when it
3631 will be necessary. */
3633 my_ns
->proc_name
= gfc_new_block
;
3637 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3639 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3640 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3641 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3642 my_ns
->proc_name
->name
, NULL
);
3644 gfc_commit_symbol (my_ns
->proc_name
);
3647 if (parent_ns
->proc_name
)
3648 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3654 /* Parse a BLOCK construct. */
3657 parse_block_construct (void)
3659 gfc_namespace
* my_ns
;
3662 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3664 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3666 new_st
.op
= EXEC_BLOCK
;
3667 new_st
.ext
.block
.ns
= my_ns
;
3668 new_st
.ext
.block
.assoc
= NULL
;
3669 accept_statement (ST_BLOCK
);
3671 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3672 gfc_current_ns
= my_ns
;
3674 parse_progunit (ST_NONE
);
3676 gfc_current_ns
= gfc_current_ns
->parent
;
3681 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3682 behind the scenes with compiler-generated variables. */
3685 parse_associate (void)
3687 gfc_namespace
* my_ns
;
3690 gfc_association_list
* a
;
3692 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3694 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3696 new_st
.op
= EXEC_BLOCK
;
3697 new_st
.ext
.block
.ns
= my_ns
;
3698 gcc_assert (new_st
.ext
.block
.assoc
);
3700 /* Add all associate-names as BLOCK variables. Creating them is enough
3701 for now, they'll get their values during trans-* phase. */
3702 gfc_current_ns
= my_ns
;
3703 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3707 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3711 sym
->attr
.flavor
= FL_VARIABLE
;
3713 sym
->declared_at
= a
->where
;
3714 gfc_set_sym_referenced (sym
);
3716 /* Initialize the typespec. It is not available in all cases,
3717 however, as it may only be set on the target during resolution.
3718 Still, sometimes it helps to have it right now -- especially
3719 for parsing component references on the associate-name
3720 in case of association to a derived-type. */
3721 sym
->ts
= a
->target
->ts
;
3724 accept_statement (ST_ASSOCIATE
);
3725 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
3728 st
= parse_executable (ST_NONE
);
3735 accept_statement (st
);
3736 my_ns
->code
= gfc_state_stack
->head
;
3740 unexpected_statement (st
);
3744 gfc_current_ns
= gfc_current_ns
->parent
;
3749 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3750 handled inside of parse_executable(), because they aren't really
3754 parse_do_block (void)
3763 s
.ext
.end_do_label
= new_st
.label1
;
3765 if (new_st
.ext
.iterator
!= NULL
)
3766 stree
= new_st
.ext
.iterator
->var
->symtree
;
3770 accept_statement (ST_DO
);
3772 top
= gfc_state_stack
->tail
;
3773 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
3776 s
.do_variable
= stree
;
3778 top
->block
= new_level (top
);
3779 top
->block
->op
= EXEC_DO
;
3782 st
= parse_executable (ST_NONE
);
3790 if (s
.ext
.end_do_label
!= NULL
3791 && s
.ext
.end_do_label
!= gfc_statement_label
)
3792 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3795 if (gfc_statement_label
!= NULL
)
3797 new_st
.op
= EXEC_NOP
;
3802 case ST_IMPLIED_ENDDO
:
3803 /* If the do-stmt of this DO construct has a do-construct-name,
3804 the corresponding end-do must be an end-do-stmt (with a matching
3805 name, but in that case we must have seen ST_ENDDO first).
3806 We only complain about this in pedantic mode. */
3807 if (gfc_current_block () != NULL
)
3808 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3809 &gfc_current_block()->declared_at
);
3814 unexpected_statement (st
);
3819 accept_statement (st
);
3823 /* Parse the statements of OpenMP do/parallel do. */
3825 static gfc_statement
3826 parse_omp_do (gfc_statement omp_st
)
3832 accept_statement (omp_st
);
3834 cp
= gfc_state_stack
->tail
;
3835 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3836 np
= new_level (cp
);
3842 st
= next_statement ();
3845 else if (st
== ST_DO
)
3848 unexpected_statement (st
);
3852 if (gfc_statement_label
!= NULL
3853 && gfc_state_stack
->previous
!= NULL
3854 && gfc_state_stack
->previous
->state
== COMP_DO
3855 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
3863 there should be no !$OMP END DO. */
3865 return ST_IMPLIED_ENDDO
;
3868 check_do_closure ();
3871 st
= next_statement ();
3872 gfc_statement omp_end_st
= ST_OMP_END_DO
;
3875 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
3876 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
3877 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
3878 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
3879 case ST_OMP_PARALLEL_DO_SIMD
:
3880 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
3882 default: gcc_unreachable ();
3884 if (st
== omp_end_st
)
3886 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
3887 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
3889 gcc_assert (new_st
.op
== EXEC_NOP
);
3890 gfc_clear_new_st ();
3891 gfc_commit_symbols ();
3892 gfc_warning_check ();
3893 st
= next_statement ();
3899 /* Parse the statements of OpenMP atomic directive. */
3901 static gfc_statement
3902 parse_omp_atomic (void)
3909 accept_statement (ST_OMP_ATOMIC
);
3911 cp
= gfc_state_stack
->tail
;
3912 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3913 np
= new_level (cp
);
3916 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3917 == GFC_OMP_ATOMIC_CAPTURE
);
3921 st
= next_statement ();
3924 else if (st
== ST_ASSIGNMENT
)
3926 accept_statement (st
);
3930 unexpected_statement (st
);
3935 st
= next_statement ();
3936 if (st
== ST_OMP_END_ATOMIC
)
3938 gfc_clear_new_st ();
3939 gfc_commit_symbols ();
3940 gfc_warning_check ();
3941 st
= next_statement ();
3943 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
3944 == GFC_OMP_ATOMIC_CAPTURE
)
3945 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
3950 /* Parse the statements of an OpenACC structured block. */
3953 parse_oacc_structured_block (gfc_statement acc_st
)
3955 gfc_statement st
, acc_end_st
;
3957 gfc_state_data s
, *sd
;
3959 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3960 if (sd
->state
== COMP_CRITICAL
)
3961 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
3963 accept_statement (acc_st
);
3965 cp
= gfc_state_stack
->tail
;
3966 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
3967 np
= new_level (cp
);
3972 case ST_OACC_PARALLEL
:
3973 acc_end_st
= ST_OACC_END_PARALLEL
;
3975 case ST_OACC_KERNELS
:
3976 acc_end_st
= ST_OACC_END_KERNELS
;
3979 acc_end_st
= ST_OACC_END_DATA
;
3981 case ST_OACC_HOST_DATA
:
3982 acc_end_st
= ST_OACC_END_HOST_DATA
;
3990 st
= parse_executable (ST_NONE
);
3993 else if (st
!= acc_end_st
)
3994 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
3995 reject_statement ();
3997 while (st
!= acc_end_st
);
3999 gcc_assert (new_st
.op
== EXEC_NOP
);
4001 gfc_clear_new_st ();
4002 gfc_commit_symbols ();
4003 gfc_warning_check ();
4007 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4009 static gfc_statement
4010 parse_oacc_loop (gfc_statement acc_st
)
4014 gfc_state_data s
, *sd
;
4016 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4017 if (sd
->state
== COMP_CRITICAL
)
4018 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4020 accept_statement (acc_st
);
4022 cp
= gfc_state_stack
->tail
;
4023 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4024 np
= new_level (cp
);
4030 st
= next_statement ();
4033 else if (st
== ST_DO
)
4037 gfc_error ("Expected DO loop at %C");
4038 reject_statement ();
4043 if (gfc_statement_label
!= NULL
4044 && gfc_state_stack
->previous
!= NULL
4045 && gfc_state_stack
->previous
->state
== COMP_DO
4046 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4049 return ST_IMPLIED_ENDDO
;
4052 check_do_closure ();
4055 st
= next_statement ();
4056 if (st
== ST_OACC_END_LOOP
)
4057 gfc_warning ("Redundant !$ACC END LOOP at %C");
4058 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4059 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4060 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4062 gcc_assert (new_st
.op
== EXEC_NOP
);
4063 gfc_clear_new_st ();
4064 gfc_commit_symbols ();
4065 gfc_warning_check ();
4066 st
= next_statement ();
4072 /* Parse the statements of an OpenMP structured block. */
4075 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4077 gfc_statement st
, omp_end_st
;
4081 accept_statement (omp_st
);
4083 cp
= gfc_state_stack
->tail
;
4084 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4085 np
= new_level (cp
);
4091 case ST_OMP_PARALLEL
:
4092 omp_end_st
= ST_OMP_END_PARALLEL
;
4094 case ST_OMP_PARALLEL_SECTIONS
:
4095 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4097 case ST_OMP_SECTIONS
:
4098 omp_end_st
= ST_OMP_END_SECTIONS
;
4100 case ST_OMP_ORDERED
:
4101 omp_end_st
= ST_OMP_END_ORDERED
;
4103 case ST_OMP_CRITICAL
:
4104 omp_end_st
= ST_OMP_END_CRITICAL
;
4107 omp_end_st
= ST_OMP_END_MASTER
;
4110 omp_end_st
= ST_OMP_END_SINGLE
;
4113 omp_end_st
= ST_OMP_END_TASK
;
4115 case ST_OMP_TASKGROUP
:
4116 omp_end_st
= ST_OMP_END_TASKGROUP
;
4118 case ST_OMP_WORKSHARE
:
4119 omp_end_st
= ST_OMP_END_WORKSHARE
;
4121 case ST_OMP_PARALLEL_WORKSHARE
:
4122 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4130 if (workshare_stmts_only
)
4132 /* Inside of !$omp workshare, only
4135 where statements and constructs
4136 forall statements and constructs
4140 are allowed. For !$omp critical these
4141 restrictions apply recursively. */
4144 st
= next_statement ();
4155 accept_statement (st
);
4158 case ST_WHERE_BLOCK
:
4159 parse_where_block ();
4162 case ST_FORALL_BLOCK
:
4163 parse_forall_block ();
4166 case ST_OMP_PARALLEL
:
4167 case ST_OMP_PARALLEL_SECTIONS
:
4168 parse_omp_structured_block (st
, false);
4171 case ST_OMP_PARALLEL_WORKSHARE
:
4172 case ST_OMP_CRITICAL
:
4173 parse_omp_structured_block (st
, true);
4176 case ST_OMP_PARALLEL_DO
:
4177 case ST_OMP_PARALLEL_DO_SIMD
:
4178 st
= parse_omp_do (st
);
4182 st
= parse_omp_atomic ();
4193 st
= next_statement ();
4197 st
= parse_executable (ST_NONE
);
4200 else if (st
== ST_OMP_SECTION
4201 && (omp_st
== ST_OMP_SECTIONS
4202 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4204 np
= new_level (np
);
4208 else if (st
!= omp_end_st
)
4209 unexpected_statement (st
);
4211 while (st
!= omp_end_st
);
4215 case EXEC_OMP_END_NOWAIT
:
4216 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4218 case EXEC_OMP_CRITICAL
:
4219 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4220 || (new_st
.ext
.omp_name
!= NULL
4221 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4222 gfc_error ("Name after !$omp critical and !$omp end critical does "
4224 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4226 case EXEC_OMP_END_SINGLE
:
4227 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4228 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4229 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4230 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4238 gfc_clear_new_st ();
4239 gfc_commit_symbols ();
4240 gfc_warning_check ();
4245 /* Accept a series of executable statements. We return the first
4246 statement that doesn't fit to the caller. Any block statements are
4247 passed on to the correct handler, which usually passes the buck
4250 static gfc_statement
4251 parse_executable (gfc_statement st
)
4256 st
= next_statement ();
4260 close_flag
= check_do_closure ();
4265 case ST_END_PROGRAM
:
4268 case ST_END_FUNCTION
:
4273 case ST_END_SUBROUTINE
:
4278 case ST_SELECT_CASE
:
4279 gfc_error ("%s statement at %C cannot terminate a non-block "
4280 "DO loop", gfc_ascii_statement (st
));
4293 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4294 "first executable statement");
4300 accept_statement (st
);
4301 if (close_flag
== 1)
4302 return ST_IMPLIED_ENDDO
;
4306 parse_block_construct ();
4317 case ST_SELECT_CASE
:
4318 parse_select_block ();
4321 case ST_SELECT_TYPE
:
4322 parse_select_type_block();
4327 if (check_do_closure () == 1)
4328 return ST_IMPLIED_ENDDO
;
4332 parse_critical_block ();
4335 case ST_WHERE_BLOCK
:
4336 parse_where_block ();
4339 case ST_FORALL_BLOCK
:
4340 parse_forall_block ();
4343 case ST_OACC_PARALLEL_LOOP
:
4344 case ST_OACC_KERNELS_LOOP
:
4346 st
= parse_oacc_loop (st
);
4347 if (st
== ST_IMPLIED_ENDDO
)
4351 case ST_OACC_PARALLEL
:
4352 case ST_OACC_KERNELS
:
4354 case ST_OACC_HOST_DATA
:
4355 parse_oacc_structured_block (st
);
4358 case ST_OMP_PARALLEL
:
4359 case ST_OMP_PARALLEL_SECTIONS
:
4360 case ST_OMP_SECTIONS
:
4361 case ST_OMP_ORDERED
:
4362 case ST_OMP_CRITICAL
:
4366 case ST_OMP_TASKGROUP
:
4367 parse_omp_structured_block (st
, false);
4370 case ST_OMP_WORKSHARE
:
4371 case ST_OMP_PARALLEL_WORKSHARE
:
4372 parse_omp_structured_block (st
, true);
4376 case ST_OMP_DO_SIMD
:
4377 case ST_OMP_PARALLEL_DO
:
4378 case ST_OMP_PARALLEL_DO_SIMD
:
4380 st
= parse_omp_do (st
);
4381 if (st
== ST_IMPLIED_ENDDO
)
4386 st
= parse_omp_atomic ();
4393 st
= next_statement ();
4398 /* Fix the symbols for sibling functions. These are incorrectly added to
4399 the child namespace as the parser didn't know about this procedure. */
4402 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4406 gfc_symbol
*old_sym
;
4408 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4410 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4412 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4413 goto fixup_contained
;
4415 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4416 && sym
->attr
.generic
&& sym
->attr
.function
)
4417 ||(sym
->attr
.flavor
== FL_DERIVED
4418 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4419 goto fixup_contained
;
4421 old_sym
= st
->n
.sym
;
4422 if (old_sym
->ns
== ns
4423 && !old_sym
->attr
.contained
4425 /* By 14.6.1.3, host association should be excluded
4426 for the following. */
4427 && !(old_sym
->attr
.external
4428 || (old_sym
->ts
.type
!= BT_UNKNOWN
4429 && !old_sym
->attr
.implicit_type
)
4430 || old_sym
->attr
.flavor
== FL_PARAMETER
4431 || old_sym
->attr
.use_assoc
4432 || old_sym
->attr
.in_common
4433 || old_sym
->attr
.in_equivalence
4434 || old_sym
->attr
.data
4435 || old_sym
->attr
.dummy
4436 || old_sym
->attr
.result
4437 || old_sym
->attr
.dimension
4438 || old_sym
->attr
.allocatable
4439 || old_sym
->attr
.intrinsic
4440 || old_sym
->attr
.generic
4441 || old_sym
->attr
.flavor
== FL_NAMELIST
4442 || old_sym
->attr
.flavor
== FL_LABEL
4443 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4445 /* Replace it with the symbol from the parent namespace. */
4449 gfc_release_symbol (old_sym
);
4453 /* Do the same for any contained procedures. */
4454 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4459 parse_contained (int module
)
4461 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4462 gfc_state_data s1
, s2
;
4466 int contains_statements
= 0;
4469 push_state (&s1
, COMP_CONTAINS
, NULL
);
4470 parent_ns
= gfc_current_ns
;
4474 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4476 gfc_current_ns
->sibling
= parent_ns
->contained
;
4477 parent_ns
->contained
= gfc_current_ns
;
4480 /* Process the next available statement. We come here if we got an error
4481 and rejected the last statement. */
4482 st
= next_statement ();
4491 contains_statements
= 1;
4492 accept_statement (st
);
4495 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4498 /* For internal procedures, create/update the symbol in the
4499 parent namespace. */
4503 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4504 gfc_error ("Contained procedure '%s' at %C is already "
4505 "ambiguous", gfc_new_block
->name
);
4508 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4510 &gfc_new_block
->declared_at
))
4512 if (st
== ST_FUNCTION
)
4513 gfc_add_function (&sym
->attr
, sym
->name
,
4514 &gfc_new_block
->declared_at
);
4516 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4517 &gfc_new_block
->declared_at
);
4521 gfc_commit_symbols ();
4524 sym
= gfc_new_block
;
4526 /* Mark this as a contained function, so it isn't replaced
4527 by other module functions. */
4528 sym
->attr
.contained
= 1;
4530 /* Set implicit_pure so that it can be reset if any of the
4531 tests for purity fail. This is used for some optimisation
4532 during translation. */
4533 if (!sym
->attr
.pure
)
4534 sym
->attr
.implicit_pure
= 1;
4536 parse_progunit (ST_NONE
);
4538 /* Fix up any sibling functions that refer to this one. */
4539 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4540 /* Or refer to any of its alternate entry points. */
4541 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4542 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4544 gfc_current_ns
->code
= s2
.head
;
4545 gfc_current_ns
= parent_ns
;
4550 /* These statements are associated with the end of the host unit. */
4551 case ST_END_FUNCTION
:
4553 case ST_END_PROGRAM
:
4554 case ST_END_SUBROUTINE
:
4555 accept_statement (st
);
4556 gfc_current_ns
->code
= s1
.head
;
4560 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4561 gfc_ascii_statement (st
));
4562 reject_statement ();
4568 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
4569 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
4571 /* The first namespace in the list is guaranteed to not have
4572 anything (worthwhile) in it. */
4573 tmp
= gfc_current_ns
;
4574 gfc_current_ns
= parent_ns
;
4575 if (seen_error
&& tmp
->refs
> 1)
4576 gfc_free_namespace (tmp
);
4578 ns
= gfc_current_ns
->contained
;
4579 gfc_current_ns
->contained
= ns
->sibling
;
4580 gfc_free_namespace (ns
);
4583 if (!contains_statements
)
4584 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
4585 "FUNCTION or SUBROUTINE statement at %C");
4589 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4592 parse_progunit (gfc_statement st
)
4597 st
= parse_spec (st
);
4604 /* This is not allowed within BLOCK! */
4605 if (gfc_current_state () != COMP_BLOCK
)
4610 accept_statement (st
);
4617 if (gfc_current_state () == COMP_FUNCTION
)
4618 gfc_check_function_type (gfc_current_ns
);
4623 st
= parse_executable (st
);
4631 /* This is not allowed within BLOCK! */
4632 if (gfc_current_state () != COMP_BLOCK
)
4637 accept_statement (st
);
4644 unexpected_statement (st
);
4645 reject_statement ();
4646 st
= next_statement ();
4652 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4653 if (p
->state
== COMP_CONTAINS
)
4656 if (gfc_find_state (COMP_MODULE
) == true)
4661 gfc_error ("CONTAINS statement at %C is already in a contained "
4663 reject_statement ();
4664 st
= next_statement ();
4668 parse_contained (0);
4671 gfc_current_ns
->code
= gfc_state_stack
->head
;
4672 if (gfc_state_stack
->state
== COMP_PROGRAM
4673 || gfc_state_stack
->state
== COMP_MODULE
4674 || gfc_state_stack
->state
== COMP_SUBROUTINE
4675 || gfc_state_stack
->state
== COMP_FUNCTION
4676 || gfc_state_stack
->state
== COMP_BLOCK
)
4677 gfc_current_ns
->oacc_declare_clauses
4678 = gfc_state_stack
->ext
.oacc_declare_clauses
;
4682 /* Come here to complain about a global symbol already in use as
4686 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
4691 where
= &gfc_current_locus
;
4701 case GSYM_SUBROUTINE
:
4702 name
= "SUBROUTINE";
4707 case GSYM_BLOCK_DATA
:
4708 name
= "BLOCK DATA";
4714 gfc_internal_error ("gfc_global_used(): Bad type");
4718 if (sym
->binding_label
)
4719 gfc_error ("Global binding name '%s' at %L is already being used as a %s "
4720 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
4722 gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
4723 sym
->name
, where
, name
, &sym
->where
);
4727 /* Parse a block data program unit. */
4730 parse_block_data (void)
4733 static locus blank_locus
;
4734 static int blank_block
=0;
4737 gfc_current_ns
->proc_name
= gfc_new_block
;
4738 gfc_current_ns
->is_block_data
= 1;
4740 if (gfc_new_block
== NULL
)
4743 gfc_error ("Blank BLOCK DATA at %C conflicts with "
4744 "prior BLOCK DATA at %L", &blank_locus
);
4748 blank_locus
= gfc_current_locus
;
4753 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4755 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
4756 gfc_global_used (s
, &gfc_new_block
->declared_at
);
4759 s
->type
= GSYM_BLOCK_DATA
;
4760 s
->where
= gfc_new_block
->declared_at
;
4765 st
= parse_spec (ST_NONE
);
4767 while (st
!= ST_END_BLOCK_DATA
)
4769 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4770 gfc_ascii_statement (st
));
4771 reject_statement ();
4772 st
= next_statement ();
4777 /* Parse a module subprogram. */
4786 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4787 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
4788 gfc_global_used (s
, &gfc_new_block
->declared_at
);
4791 s
->type
= GSYM_MODULE
;
4792 s
->where
= gfc_new_block
->declared_at
;
4796 st
= parse_spec (ST_NONE
);
4806 parse_contained (1);
4810 accept_statement (st
);
4814 gfc_error ("Unexpected %s statement in MODULE at %C",
4815 gfc_ascii_statement (st
));
4818 reject_statement ();
4819 st
= next_statement ();
4823 /* Make sure not to free the namespace twice on error. */
4825 s
->ns
= gfc_current_ns
;
4829 /* Add a procedure name to the global symbol table. */
4832 add_global_procedure (bool sub
)
4836 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
4837 name is a global identifier. */
4838 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
4840 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4843 || (s
->type
!= GSYM_UNKNOWN
4844 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
4846 gfc_global_used (s
, &gfc_new_block
->declared_at
);
4847 /* Silence follow-up errors. */
4848 gfc_new_block
->binding_label
= NULL
;
4852 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
4853 s
->sym_name
= gfc_new_block
->name
;
4854 s
->where
= gfc_new_block
->declared_at
;
4856 s
->ns
= gfc_current_ns
;
4860 /* Don't add the symbol multiple times. */
4861 if (gfc_new_block
->binding_label
4862 && (!gfc_notification_std (GFC_STD_F2008
)
4863 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
4865 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
4868 || (s
->type
!= GSYM_UNKNOWN
4869 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
4871 gfc_global_used (s
, &gfc_new_block
->declared_at
);
4872 /* Silence follow-up errors. */
4873 gfc_new_block
->binding_label
= NULL
;
4877 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
4878 s
->sym_name
= gfc_new_block
->name
;
4879 s
->binding_label
= gfc_new_block
->binding_label
;
4880 s
->where
= gfc_new_block
->declared_at
;
4882 s
->ns
= gfc_current_ns
;
4888 /* Add a program to the global symbol table. */
4891 add_global_program (void)
4895 if (gfc_new_block
== NULL
)
4897 s
= gfc_get_gsymbol (gfc_new_block
->name
);
4899 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
4900 gfc_global_used (s
, &gfc_new_block
->declared_at
);
4903 s
->type
= GSYM_PROGRAM
;
4904 s
->where
= gfc_new_block
->declared_at
;
4906 s
->ns
= gfc_current_ns
;
4911 /* Resolve all the program units. */
4913 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4915 gfc_free_dt_list ();
4916 gfc_current_ns
= gfc_global_ns_list
;
4917 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4919 if (gfc_current_ns
->proc_name
4920 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4921 continue; /* Already resolved. */
4923 if (gfc_current_ns
->proc_name
)
4924 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4925 gfc_resolve (gfc_current_ns
);
4926 gfc_current_ns
->derived_types
= gfc_derived_types
;
4927 gfc_derived_types
= NULL
;
4933 clean_up_modules (gfc_gsymbol
*gsym
)
4938 clean_up_modules (gsym
->left
);
4939 clean_up_modules (gsym
->right
);
4941 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
4944 gfc_current_ns
= gsym
->ns
;
4945 gfc_derived_types
= gfc_current_ns
->derived_types
;
4952 /* Translate all the program units. This could be in a different order
4953 to resolution if there are forward references in the file. */
4955 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
4959 gfc_current_ns
= gfc_global_ns_list
;
4960 gfc_get_errors (NULL
, &errors
);
4962 /* We first translate all modules to make sure that later parts
4963 of the program can use the decl. Then we translate the nonmodules. */
4965 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4967 if (!gfc_current_ns
->proc_name
4968 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
4971 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4972 gfc_derived_types
= gfc_current_ns
->derived_types
;
4973 gfc_generate_module_code (gfc_current_ns
);
4974 gfc_current_ns
->translated
= 1;
4977 gfc_current_ns
= gfc_global_ns_list
;
4978 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
4980 if (gfc_current_ns
->proc_name
4981 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4984 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
4985 gfc_derived_types
= gfc_current_ns
->derived_types
;
4986 gfc_generate_code (gfc_current_ns
);
4987 gfc_current_ns
->translated
= 1;
4990 /* Clean up all the namespaces after translation. */
4991 gfc_current_ns
= gfc_global_ns_list
;
4992 for (;gfc_current_ns
;)
4996 if (gfc_current_ns
->proc_name
4997 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
4999 gfc_current_ns
= gfc_current_ns
->sibling
;
5003 ns
= gfc_current_ns
->sibling
;
5004 gfc_derived_types
= gfc_current_ns
->derived_types
;
5006 gfc_current_ns
= ns
;
5009 clean_up_modules (gfc_gsym_root
);
5013 /* Top level parser. */
5016 gfc_parse_file (void)
5018 int seen_program
, errors_before
, errors
;
5019 gfc_state_data top
, s
;
5022 gfc_namespace
*next
;
5024 gfc_start_source_files ();
5026 top
.state
= COMP_NONE
;
5028 top
.previous
= NULL
;
5029 top
.head
= top
.tail
= NULL
;
5030 top
.do_variable
= NULL
;
5032 gfc_state_stack
= &top
;
5034 gfc_clear_new_st ();
5036 gfc_statement_label
= NULL
;
5038 if (setjmp (eof_buf
))
5039 return false; /* Come here on unexpected EOF */
5041 /* Prepare the global namespace that will contain the
5043 gfc_global_ns_list
= next
= NULL
;
5048 /* Exit early for empty files. */
5054 st
= next_statement ();
5063 goto duplicate_main
;
5065 prog_locus
= gfc_current_locus
;
5067 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5068 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5069 accept_statement (st
);
5070 add_global_program ();
5071 parse_progunit (ST_NONE
);
5076 add_global_procedure (true);
5077 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5078 accept_statement (st
);
5079 parse_progunit (ST_NONE
);
5084 add_global_procedure (false);
5085 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5086 accept_statement (st
);
5087 parse_progunit (ST_NONE
);
5092 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5093 accept_statement (st
);
5094 parse_block_data ();
5098 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5099 accept_statement (st
);
5101 gfc_get_errors (NULL
, &errors_before
);
5105 /* Anything else starts a nameless main program block. */
5108 goto duplicate_main
;
5110 prog_locus
= gfc_current_locus
;
5112 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5113 main_program_symbol (gfc_current_ns
, "MAIN__");
5114 parse_progunit (st
);
5119 /* Handle the non-program units. */
5120 gfc_current_ns
->code
= s
.head
;
5122 gfc_resolve (gfc_current_ns
);
5124 /* Dump the parse tree if requested. */
5125 if (gfc_option
.dump_fortran_original
)
5126 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5128 gfc_get_errors (NULL
, &errors
);
5129 if (s
.state
== COMP_MODULE
)
5131 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5132 gfc_current_ns
->derived_types
= gfc_derived_types
;
5133 gfc_derived_types
= NULL
;
5139 gfc_generate_code (gfc_current_ns
);
5147 /* The main program and non-contained procedures are put
5148 in the global namespace list, so that they can be processed
5149 later and all their interfaces resolved. */
5150 gfc_current_ns
->code
= s
.head
;
5153 for (; next
->sibling
; next
= next
->sibling
)
5155 next
->sibling
= gfc_current_ns
;
5158 gfc_global_ns_list
= gfc_current_ns
;
5160 next
= gfc_current_ns
;
5167 /* Do the resolution. */
5168 resolve_all_program_units (gfc_global_ns_list
);
5170 /* Do the parse tree dump. */
5172 = gfc_option
.dump_fortran_original
? gfc_global_ns_list
: NULL
;
5174 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5175 if (!gfc_current_ns
->proc_name
5176 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5178 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5179 fputs ("------------------------------------------\n\n", stdout
);
5182 /* Do the translation. */
5183 translate_all_program_units (gfc_global_ns_list
);
5185 gfc_end_source_files ();
5189 /* If we see a duplicate main program, shut down. If the second
5190 instance is an implied main program, i.e. data decls or executable
5191 statements, we're in for lots of errors. */
5192 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
5193 reject_statement ();