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 /* Like match_word, but if str is matched, set a flag that it
80 match_word_omp_simd (const char *str
, match (*subr
) (void), locus
*old_locus
,
97 gfc_current_locus
= *old_locus
;
105 /* Load symbols from all USE statements encountered in this scoping unit. */
110 gfc_error_buf old_error
;
112 gfc_push_error (&old_error
);
113 gfc_buffer_error (0);
115 gfc_buffer_error (1);
116 gfc_pop_error (&old_error
);
117 gfc_commit_symbols ();
118 gfc_warning_check ();
119 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
120 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
121 last_was_use_stmt
= false;
125 /* Figure out what the next statement is, (mostly) regardless of
126 proper ordering. The do...while(0) is there to prevent if/else
129 #define match(keyword, subr, st) \
131 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
134 undo_new_statement (); \
138 /* This is a specialist version of decode_statement that is used
139 for the specification statements in a function, whose
140 characteristics are deferred into the specification statements.
141 eg.: INTEGER (king = mykind) foo ()
142 USE mymodule, ONLY mykind.....
143 The KIND parameter needs a return after USE or IMPORT, whereas
144 derived type declarations can occur anywhere, up the executable
145 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
146 out of the correct kind of specification statements. */
148 decode_specification_statement (void)
154 if (gfc_match_eos () == MATCH_YES
)
157 old_locus
= gfc_current_locus
;
159 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
161 last_was_use_stmt
= true;
166 undo_new_statement ();
167 if (last_was_use_stmt
)
171 match ("import", gfc_match_import
, ST_IMPORT
);
173 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
176 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
177 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
178 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
180 /* General statement matching: Instead of testing every possible
181 statement, we eliminate most possibilities by peeking at the
184 c
= gfc_peek_ascii_char ();
189 match ("abstract% interface", gfc_match_abstract_interface
,
191 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
192 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
196 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
200 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
201 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
205 match ("data", gfc_match_data
, ST_DATA
);
206 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
210 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
211 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
212 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
213 match ("external", gfc_match_external
, ST_ATTR_DECL
);
217 match ("format", gfc_match_format
, ST_FORMAT
);
224 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
225 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
226 match ("interface", gfc_match_interface
, ST_INTERFACE
);
227 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
228 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
235 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
239 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
243 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
244 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
245 if (gfc_match_private (&st
) == MATCH_YES
)
247 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
248 if (gfc_match_public (&st
) == MATCH_YES
)
250 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
257 match ("save", gfc_match_save
, ST_ATTR_DECL
);
261 match ("target", gfc_match_target
, ST_ATTR_DECL
);
262 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
269 match ("value", gfc_match_value
, ST_ATTR_DECL
);
270 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
277 /* This is not a specification statement. See if any of the matchers
278 has stored an error message of some sort. */
282 gfc_buffer_error (0);
283 gfc_current_locus
= old_locus
;
285 return ST_GET_FCN_CHARACTERISTICS
;
289 /* This is the primary 'decode_statement'. */
291 decode_statement (void)
299 gfc_enforce_clean_symbol_state ();
301 gfc_clear_error (); /* Clear any pending errors. */
302 gfc_clear_warning (); /* Clear any pending warnings. */
304 gfc_matching_function
= false;
306 if (gfc_match_eos () == MATCH_YES
)
309 if (gfc_current_state () == COMP_FUNCTION
310 && gfc_current_block ()->result
->ts
.kind
== -1)
311 return decode_specification_statement ();
313 old_locus
= gfc_current_locus
;
315 c
= gfc_peek_ascii_char ();
319 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
321 last_was_use_stmt
= true;
325 undo_new_statement ();
328 if (last_was_use_stmt
)
331 /* Try matching a data declaration or function declaration. The
332 input "REALFUNCTIONA(N)" can mean several things in different
333 contexts, so it (and its relatives) get special treatment. */
335 if (gfc_current_state () == COMP_NONE
336 || gfc_current_state () == COMP_INTERFACE
337 || gfc_current_state () == COMP_CONTAINS
)
339 gfc_matching_function
= true;
340 m
= gfc_match_function_decl ();
343 else if (m
== MATCH_ERROR
)
347 gfc_current_locus
= old_locus
;
349 gfc_matching_function
= false;
352 /* Match statements whose error messages are meant to be overwritten
353 by something better. */
355 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
356 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
357 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
359 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
360 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
362 /* Try to match a subroutine statement, which has the same optional
363 prefixes that functions can have. */
365 if (gfc_match_subroutine () == MATCH_YES
)
366 return ST_SUBROUTINE
;
368 gfc_current_locus
= old_locus
;
370 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
371 statements, which might begin with a block label. The match functions for
372 these statements are unusual in that their keyword is not seen before
373 the matcher is called. */
375 if (gfc_match_if (&st
) == MATCH_YES
)
378 gfc_current_locus
= old_locus
;
380 if (gfc_match_where (&st
) == MATCH_YES
)
383 gfc_current_locus
= old_locus
;
385 if (gfc_match_forall (&st
) == MATCH_YES
)
388 gfc_current_locus
= old_locus
;
390 match (NULL
, gfc_match_do
, ST_DO
);
391 match (NULL
, gfc_match_block
, ST_BLOCK
);
392 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
393 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
394 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
396 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
397 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
399 gfc_current_ns
= gfc_current_ns
->parent
;
400 gfc_free_namespace (ns
);
402 /* General statement matching: Instead of testing every possible
403 statement, we eliminate most possibilities by peeking at the
409 match ("abstract% interface", gfc_match_abstract_interface
,
411 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
412 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
413 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
414 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
418 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
419 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
420 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
424 match ("call", gfc_match_call
, ST_CALL
);
425 match ("close", gfc_match_close
, ST_CLOSE
);
426 match ("continue", gfc_match_continue
, ST_CONTINUE
);
427 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
428 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
429 match ("case", gfc_match_case
, ST_CASE
);
430 match ("common", gfc_match_common
, ST_COMMON
);
431 match ("contains", gfc_match_eos
, ST_CONTAINS
);
432 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
433 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
437 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
438 match ("data", gfc_match_data
, ST_DATA
);
439 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
443 match ("end file", gfc_match_endfile
, ST_END_FILE
);
444 match ("exit", gfc_match_exit
, ST_EXIT
);
445 match ("else", gfc_match_else
, ST_ELSE
);
446 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
447 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
448 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
449 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
451 if (gfc_match_end (&st
) == MATCH_YES
)
454 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
455 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
456 match ("external", gfc_match_external
, ST_ATTR_DECL
);
460 match ("final", gfc_match_final_decl
, ST_FINAL
);
461 match ("flush", gfc_match_flush
, ST_FLUSH
);
462 match ("format", gfc_match_format
, ST_FORMAT
);
466 match ("generic", gfc_match_generic
, ST_GENERIC
);
467 match ("go to", gfc_match_goto
, ST_GOTO
);
471 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
472 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
473 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
474 match ("import", gfc_match_import
, ST_IMPORT
);
475 match ("interface", gfc_match_interface
, ST_INTERFACE
);
476 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
477 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
481 match ("lock", gfc_match_lock
, ST_LOCK
);
485 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
486 match ("module", gfc_match_module
, ST_MODULE
);
490 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
491 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
495 match ("open", gfc_match_open
, ST_OPEN
);
496 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
500 match ("print", gfc_match_print
, ST_WRITE
);
501 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
502 match ("pause", gfc_match_pause
, ST_PAUSE
);
503 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
504 if (gfc_match_private (&st
) == MATCH_YES
)
506 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
507 match ("program", gfc_match_program
, ST_PROGRAM
);
508 if (gfc_match_public (&st
) == MATCH_YES
)
510 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
514 match ("read", gfc_match_read
, ST_READ
);
515 match ("return", gfc_match_return
, ST_RETURN
);
516 match ("rewind", gfc_match_rewind
, ST_REWIND
);
520 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
521 match ("stop", gfc_match_stop
, ST_STOP
);
522 match ("save", gfc_match_save
, ST_ATTR_DECL
);
523 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
524 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
525 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
529 match ("target", gfc_match_target
, ST_ATTR_DECL
);
530 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
531 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
535 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
539 match ("value", gfc_match_value
, ST_ATTR_DECL
);
540 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
544 match ("wait", gfc_match_wait
, ST_WAIT
);
545 match ("write", gfc_match_write
, ST_WRITE
);
549 /* All else has failed, so give up. See if any of the matchers has
550 stored an error message of some sort. */
552 if (gfc_error_check () == 0)
553 gfc_error_now ("Unclassifiable statement at %C");
557 gfc_error_recovery ();
562 /* Like match, but set a flag simd_matched if keyword matched. */
563 #define matchs(keyword, subr, st) \
565 if (match_word_omp_simd (keyword, subr, &old_locus, \
566 &simd_matched) == MATCH_YES) \
569 undo_new_statement (); \
572 /* Like match, but don't match anything if not -fopenmp. */
573 #define matcho(keyword, subr, st) \
575 if (!gfc_option.gfc_flag_openmp) \
577 else if (match_word (keyword, subr, &old_locus) \
581 undo_new_statement (); \
585 decode_oacc_directive (void)
590 gfc_enforce_clean_symbol_state ();
592 gfc_clear_error (); /* Clear any pending errors. */
593 gfc_clear_warning (); /* Clear any pending warnings. */
597 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
599 gfc_error_recovery ();
603 gfc_unset_implicit_pure (NULL
);
605 old_locus
= gfc_current_locus
;
607 /* General OpenACC directive matching: Instead of testing every possible
608 statement, we eliminate most possibilities by peeking at the
611 c
= gfc_peek_ascii_char ();
616 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
619 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
620 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
623 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
624 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
625 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
626 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
627 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
628 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
629 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
630 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
631 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
634 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
637 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
638 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
641 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
642 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
645 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
648 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
651 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
655 /* Directive not found or stored an error message.
656 Check and give up. */
658 if (gfc_error_check () == 0)
659 gfc_error_now ("Unclassifiable OpenACC directive at %C");
663 gfc_error_recovery ();
669 decode_omp_directive (void)
673 bool simd_matched
= false;
675 gfc_enforce_clean_symbol_state ();
677 gfc_clear_error (); /* Clear any pending errors. */
678 gfc_clear_warning (); /* Clear any pending warnings. */
682 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
683 "or ELEMENTAL procedures");
684 gfc_error_recovery ();
688 gfc_unset_implicit_pure (NULL
);
690 old_locus
= gfc_current_locus
;
692 /* General OpenMP directive matching: Instead of testing every possible
693 statement, we eliminate most possibilities by peeking at the
696 c
= gfc_peek_ascii_char ();
698 /* match is for directives that should be recognized only if
699 -fopenmp, matchs for directives that should be recognized
700 if either -fopenmp or -fopenmp-simd. */
704 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
707 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
710 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
711 ST_OMP_CANCELLATION_POINT
);
712 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
713 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
716 matchs ("declare reduction", gfc_match_omp_declare_reduction
,
717 ST_OMP_DECLARE_REDUCTION
);
718 matchs ("declare simd", gfc_match_omp_declare_simd
,
719 ST_OMP_DECLARE_SIMD
);
720 matcho ("declare target", gfc_match_omp_declare_target
,
721 ST_OMP_DECLARE_TARGET
);
722 matchs ("distribute parallel do simd",
723 gfc_match_omp_distribute_parallel_do_simd
,
724 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
725 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
726 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
727 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
728 ST_OMP_DISTRIBUTE_SIMD
);
729 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
730 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
731 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
734 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
735 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
736 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
737 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
738 matcho ("end distribute parallel do", gfc_match_omp_eos
,
739 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
740 matchs ("end distribute simd", gfc_match_omp_eos
,
741 ST_OMP_END_DISTRIBUTE_SIMD
);
742 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
743 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
744 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
745 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
746 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
747 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
748 matchs ("end parallel do simd", gfc_match_omp_eos
,
749 ST_OMP_END_PARALLEL_DO_SIMD
);
750 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
751 matcho ("end parallel sections", gfc_match_omp_eos
,
752 ST_OMP_END_PARALLEL_SECTIONS
);
753 matcho ("end parallel workshare", gfc_match_omp_eos
,
754 ST_OMP_END_PARALLEL_WORKSHARE
);
755 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
756 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
757 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
758 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
759 matchs ("end target teams distribute parallel do simd",
761 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
762 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
763 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
764 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
765 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
766 matcho ("end target teams distribute", gfc_match_omp_eos
,
767 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
768 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
769 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
770 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
771 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
772 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
773 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
774 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
775 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
776 matchs ("end teams distribute simd", gfc_match_omp_eos
,
777 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
778 matcho ("end teams distribute", gfc_match_omp_eos
,
779 ST_OMP_END_TEAMS_DISTRIBUTE
);
780 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
781 matcho ("end workshare", gfc_match_omp_end_nowait
,
782 ST_OMP_END_WORKSHARE
);
785 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
788 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
791 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
794 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
795 ST_OMP_PARALLEL_DO_SIMD
);
796 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
797 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
798 ST_OMP_PARALLEL_SECTIONS
);
799 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
800 ST_OMP_PARALLEL_WORKSHARE
);
801 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
804 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
805 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
806 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
807 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
810 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
811 matchs ("target teams distribute parallel do simd",
812 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
813 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
814 matcho ("target teams distribute parallel do",
815 gfc_match_omp_target_teams_distribute_parallel_do
,
816 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
817 matchs ("target teams distribute simd",
818 gfc_match_omp_target_teams_distribute_simd
,
819 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
820 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
821 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
822 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
823 matcho ("target update", gfc_match_omp_target_update
,
824 ST_OMP_TARGET_UPDATE
);
825 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
826 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
827 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
828 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
829 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
830 matchs ("teams distribute parallel do simd",
831 gfc_match_omp_teams_distribute_parallel_do_simd
,
832 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
833 matcho ("teams distribute parallel do",
834 gfc_match_omp_teams_distribute_parallel_do
,
835 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
836 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
837 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
838 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
839 ST_OMP_TEAMS_DISTRIBUTE
);
840 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
841 matcho ("threadprivate", gfc_match_omp_threadprivate
,
842 ST_OMP_THREADPRIVATE
);
845 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
849 /* All else has failed, so give up. See if any of the matchers has
850 stored an error message of some sort. Don't error out if
851 not -fopenmp and simd_matched is false, i.e. if a directive other
852 than one marked with match has been seen. */
854 if (gfc_option
.gfc_flag_openmp
|| simd_matched
)
856 if (gfc_error_check () == 0)
857 gfc_error_now ("Unclassifiable OpenMP directive at %C");
862 gfc_error_recovery ();
868 decode_gcc_attribute (void)
872 gfc_enforce_clean_symbol_state ();
874 gfc_clear_error (); /* Clear any pending errors. */
875 gfc_clear_warning (); /* Clear any pending warnings. */
876 old_locus
= gfc_current_locus
;
878 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
880 /* All else has failed, so give up. See if any of the matchers has
881 stored an error message of some sort. */
883 if (gfc_error_check () == 0)
884 gfc_error_now ("Unclassifiable GCC directive at %C");
888 gfc_error_recovery ();
895 /* Assert next length characters to be equal to token in free form. */
898 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
903 c
= gfc_next_ascii_char ();
904 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
905 gcc_assert (c
== token
[i
]);
907 gcc_assert (gfc_is_whitespace(c
));
908 gfc_gobble_whitespace ();
909 if (last_was_use_stmt
)
913 /* Get the next statement in free form source. */
922 at_bol
= gfc_at_bol ();
923 gfc_gobble_whitespace ();
925 c
= gfc_peek_ascii_char ();
931 /* Found a statement label? */
932 m
= gfc_match_st_label (&gfc_statement_label
);
934 d
= gfc_peek_ascii_char ();
935 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
937 gfc_match_small_literal_int (&i
, &cnt
);
940 gfc_error_now ("Too many digits in statement label at %C");
943 gfc_error_now ("Zero is not a valid statement label at %C");
946 c
= gfc_next_ascii_char ();
949 if (!gfc_is_whitespace (c
))
950 gfc_error_now ("Non-numeric character in statement label at %C");
956 label_locus
= gfc_current_locus
;
958 gfc_gobble_whitespace ();
960 if (at_bol
&& gfc_peek_ascii_char () == ';')
962 gfc_error_now ("Semicolon at %C needs to be preceded by "
964 gfc_next_ascii_char (); /* Eat up the semicolon. */
968 if (gfc_match_eos () == MATCH_YES
)
970 gfc_warning_now ("Ignoring statement label in empty statement "
971 "at %L", &label_locus
);
972 gfc_free_st_label (gfc_statement_label
);
973 gfc_statement_label
= NULL
;
980 /* Comments have already been skipped by the time we get here,
981 except for GCC attributes and OpenMP/OpenACC directives. */
983 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
984 c
= gfc_peek_ascii_char ();
990 c
= gfc_next_ascii_char ();
991 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
992 gcc_assert (c
== "gcc$"[i
]);
994 gfc_gobble_whitespace ();
995 return decode_gcc_attribute ();
1000 /* Since both OpenMP and OpenACC directives starts with
1001 !$ character sequence, we must check all flags combinations */
1002 if ((gfc_option
.gfc_flag_openmp
1003 || gfc_option
.gfc_flag_openmp_simd
)
1004 && !gfc_option
.gfc_flag_openacc
)
1006 verify_token_free ("$omp", 4, last_was_use_stmt
);
1007 return decode_omp_directive ();
1009 else if ((gfc_option
.gfc_flag_openmp
1010 || gfc_option
.gfc_flag_openmp_simd
)
1011 && gfc_option
.gfc_flag_openacc
)
1013 gfc_next_ascii_char (); /* Eat up dollar character */
1014 c
= gfc_peek_ascii_char ();
1018 verify_token_free ("omp", 3, last_was_use_stmt
);
1019 return decode_omp_directive ();
1023 verify_token_free ("acc", 3, last_was_use_stmt
);
1024 return decode_oacc_directive ();
1027 else if (gfc_option
.gfc_flag_openacc
)
1029 verify_token_free ("$acc", 4, last_was_use_stmt
);
1030 return decode_oacc_directive ();
1036 if (at_bol
&& c
== ';')
1038 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1039 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1041 gfc_next_ascii_char (); /* Eat up the semicolon. */
1045 return decode_statement ();
1048 /* Assert next length characters to be equal to token in fixed form. */
1051 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1054 char c
= gfc_next_char_literal (NONSTRING
);
1056 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1057 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1059 if (c
!= ' ' && c
!= '0')
1061 gfc_buffer_error (0);
1062 gfc_error ("Bad continuation line at %C");
1065 if (last_was_use_stmt
)
1071 /* Get the next statement in fixed-form source. */
1073 static gfc_statement
1076 int label
, digit_flag
, i
;
1081 return decode_statement ();
1083 /* Skip past the current label field, parsing a statement label if
1084 one is there. This is a weird number parser, since the number is
1085 contained within five columns and can have any kind of embedded
1086 spaces. We also check for characters that make the rest of the
1092 for (i
= 0; i
< 5; i
++)
1094 c
= gfc_next_char_literal (NONSTRING
);
1111 label
= label
* 10 + ((unsigned char) c
- '0');
1112 label_locus
= gfc_current_locus
;
1116 /* Comments have already been skipped by the time we get
1117 here, except for GCC attributes and OpenMP directives. */
1120 c
= gfc_next_char_literal (NONSTRING
);
1122 if (TOLOWER (c
) == 'g')
1124 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1125 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1127 return decode_gcc_attribute ();
1131 if ((gfc_option
.gfc_flag_openmp
1132 || gfc_option
.gfc_flag_openmp_simd
)
1133 && !gfc_option
.gfc_flag_openacc
)
1135 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1137 return decode_omp_directive ();
1139 else if ((gfc_option
.gfc_flag_openmp
1140 || gfc_option
.gfc_flag_openmp_simd
)
1141 && gfc_option
.gfc_flag_openacc
)
1143 c
= gfc_next_char_literal(NONSTRING
);
1144 if (c
== 'o' || c
== 'O')
1146 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1148 return decode_omp_directive ();
1150 else if (c
== 'a' || c
== 'A')
1152 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1154 return decode_oacc_directive ();
1157 else if (gfc_option
.gfc_flag_openacc
)
1159 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1161 return decode_oacc_directive ();
1166 /* Comments have already been skipped by the time we get
1167 here so don't bother checking for them. */
1170 gfc_buffer_error (0);
1171 gfc_error ("Non-numeric character in statement label at %C");
1179 gfc_warning_now ("Zero is not a valid statement label at %C");
1182 /* We've found a valid statement label. */
1183 gfc_statement_label
= gfc_get_st_label (label
);
1187 /* Since this line starts a statement, it cannot be a continuation
1188 of a previous statement. If we see something here besides a
1189 space or zero, it must be a bad continuation line. */
1191 c
= gfc_next_char_literal (NONSTRING
);
1195 if (c
!= ' ' && c
!= '0')
1197 gfc_buffer_error (0);
1198 gfc_error ("Bad continuation line at %C");
1202 /* Now that we've taken care of the statement label columns, we have
1203 to make sure that the first nonblank character is not a '!'. If
1204 it is, the rest of the line is a comment. */
1208 loc
= gfc_current_locus
;
1209 c
= gfc_next_char_literal (NONSTRING
);
1211 while (gfc_is_whitespace (c
));
1215 gfc_current_locus
= loc
;
1220 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1221 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1222 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1227 if (gfc_match_eos () == MATCH_YES
)
1230 /* At this point, we've got a nonblank statement to parse. */
1231 return decode_statement ();
1235 gfc_warning_now ("Ignoring statement label in empty statement at %L",
1238 gfc_current_locus
.lb
->truncated
= 0;
1239 gfc_advance_line ();
1244 /* Return the next non-ST_NONE statement to the caller. We also worry
1245 about including files and the ends of include files at this stage. */
1247 static gfc_statement
1248 next_statement (void)
1253 gfc_enforce_clean_symbol_state ();
1255 gfc_new_block
= NULL
;
1257 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1258 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1261 gfc_statement_label
= NULL
;
1262 gfc_buffer_error (1);
1265 gfc_advance_line ();
1267 gfc_skip_comments ();
1275 if (gfc_define_undef_line ())
1278 old_locus
= gfc_current_locus
;
1280 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1286 gfc_buffer_error (0);
1288 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1290 gfc_free_st_label (gfc_statement_label
);
1291 gfc_statement_label
= NULL
;
1292 gfc_current_locus
= old_locus
;
1296 check_statement_label (st
);
1302 /****************************** Parser ***********************************/
1304 /* The parser subroutines are of type 'try' that fail if the file ends
1307 /* Macros that expand to case-labels for various classes of
1308 statements. Start with executable statements that directly do
1311 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1312 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1313 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1314 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1315 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1316 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1317 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1318 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1319 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1320 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1321 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1322 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1323 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1324 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1326 /* Statements that mark other executable statements. */
1328 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1329 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1330 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1331 case ST_OMP_PARALLEL: \
1332 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1333 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1334 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1335 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1336 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1337 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1338 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1339 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1340 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1341 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1342 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1343 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1344 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1345 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1346 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1347 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1348 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1350 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1351 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1353 /* Declaration statements */
1355 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1356 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1357 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1358 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1359 case ST_OMP_DECLARE_TARGET
1361 /* Block end statements. Errors associated with interchanging these
1362 are detected in gfc_match_end(). */
1364 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1365 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1366 case ST_END_BLOCK: case ST_END_ASSOCIATE
1369 /* Push a new state onto the stack. */
1372 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1374 p
->state
= new_state
;
1375 p
->previous
= gfc_state_stack
;
1377 p
->head
= p
->tail
= NULL
;
1378 p
->do_variable
= NULL
;
1379 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1380 p
->ext
.oacc_declare_clauses
= NULL
;
1382 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1383 construct statement was accepted right before pushing the state. Thus,
1384 the construct's gfc_code is available as tail of the parent state. */
1385 gcc_assert (gfc_state_stack
);
1386 p
->construct
= gfc_state_stack
->tail
;
1388 gfc_state_stack
= p
;
1392 /* Pop the current state. */
1396 gfc_state_stack
= gfc_state_stack
->previous
;
1400 /* Try to find the given state in the state stack. */
1403 gfc_find_state (gfc_compile_state state
)
1407 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1408 if (p
->state
== state
)
1411 return (p
== NULL
) ? false : true;
1415 /* Starts a new level in the statement list. */
1418 new_level (gfc_code
*q
)
1422 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1424 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1430 /* Add the current new_st code structure and adds it to the current
1431 program unit. As a side-effect, it zeroes the new_st. */
1434 add_statement (void)
1438 p
= XCNEW (gfc_code
);
1441 p
->loc
= gfc_current_locus
;
1443 if (gfc_state_stack
->head
== NULL
)
1444 gfc_state_stack
->head
= p
;
1446 gfc_state_stack
->tail
->next
= p
;
1448 while (p
->next
!= NULL
)
1451 gfc_state_stack
->tail
= p
;
1453 gfc_clear_new_st ();
1459 /* Frees everything associated with the current statement. */
1462 undo_new_statement (void)
1464 gfc_free_statements (new_st
.block
);
1465 gfc_free_statements (new_st
.next
);
1466 gfc_free_statement (&new_st
);
1467 gfc_clear_new_st ();
1471 /* If the current statement has a statement label, make sure that it
1472 is allowed to, or should have one. */
1475 check_statement_label (gfc_statement st
)
1479 if (gfc_statement_label
== NULL
)
1481 if (st
== ST_FORMAT
)
1482 gfc_error ("FORMAT statement at %L does not have a statement label",
1489 case ST_END_PROGRAM
:
1490 case ST_END_FUNCTION
:
1491 case ST_END_SUBROUTINE
:
1495 case ST_END_CRITICAL
:
1497 case ST_END_ASSOCIATE
:
1500 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1501 type
= ST_LABEL_DO_TARGET
;
1503 type
= ST_LABEL_TARGET
;
1507 type
= ST_LABEL_FORMAT
;
1510 /* Statement labels are not restricted from appearing on a
1511 particular line. However, there are plenty of situations
1512 where the resulting label can't be referenced. */
1515 type
= ST_LABEL_BAD_TARGET
;
1519 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1521 new_st
.here
= gfc_statement_label
;
1525 /* Figures out what the enclosing program unit is. This will be a
1526 function, subroutine, program, block data or module. */
1529 gfc_enclosing_unit (gfc_compile_state
* result
)
1533 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1534 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1535 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1536 || p
->state
== COMP_PROGRAM
)
1545 *result
= COMP_PROGRAM
;
1550 /* Translate a statement enum to a string. */
1553 gfc_ascii_statement (gfc_statement st
)
1559 case ST_ARITHMETIC_IF
:
1560 p
= _("arithmetic IF");
1569 p
= _("attribute declaration");
1605 p
= _("data declaration");
1613 case ST_DERIVED_DECL
:
1614 p
= _("derived type declaration");
1628 case ST_END_ASSOCIATE
:
1629 p
= "END ASSOCIATE";
1634 case ST_END_BLOCK_DATA
:
1635 p
= "END BLOCK DATA";
1637 case ST_END_CRITICAL
:
1649 case ST_END_FUNCTION
:
1655 case ST_END_INTERFACE
:
1656 p
= "END INTERFACE";
1661 case ST_END_PROGRAM
:
1667 case ST_END_SUBROUTINE
:
1668 p
= "END SUBROUTINE";
1679 case ST_EQUIVALENCE
:
1691 case ST_FORALL_BLOCK
: /* Fall through */
1713 case ST_IMPLICIT_NONE
:
1714 p
= "IMPLICIT NONE";
1716 case ST_IMPLIED_ENDDO
:
1717 p
= _("implied END DO");
1746 case ST_MODULE_PROC
:
1747 p
= "MODULE PROCEDURE";
1779 case ST_SYNC_IMAGES
:
1782 case ST_SYNC_MEMORY
:
1797 case ST_WHERE_BLOCK
: /* Fall through */
1808 p
= _("assignment");
1810 case ST_POINTER_ASSIGNMENT
:
1811 p
= _("pointer assignment");
1813 case ST_SELECT_CASE
:
1816 case ST_SELECT_TYPE
:
1831 case ST_STATEMENT_FUNCTION
:
1832 p
= "STATEMENT FUNCTION";
1834 case ST_LABEL_ASSIGNMENT
:
1835 p
= "LABEL ASSIGNMENT";
1838 p
= "ENUM DEFINITION";
1841 p
= "ENUMERATOR DEFINITION";
1846 case ST_OACC_PARALLEL_LOOP
:
1847 p
= "!$ACC PARALLEL LOOP";
1849 case ST_OACC_END_PARALLEL_LOOP
:
1850 p
= "!$ACC END PARALLEL LOOP";
1852 case ST_OACC_PARALLEL
:
1853 p
= "!$ACC PARALLEL";
1855 case ST_OACC_END_PARALLEL
:
1856 p
= "!$ACC END PARALLEL";
1858 case ST_OACC_KERNELS
:
1859 p
= "!$ACC KERNELS";
1861 case ST_OACC_END_KERNELS
:
1862 p
= "!$ACC END KERNELS";
1864 case ST_OACC_KERNELS_LOOP
:
1865 p
= "!$ACC KERNELS LOOP";
1867 case ST_OACC_END_KERNELS_LOOP
:
1868 p
= "!$ACC END KERNELS LOOP";
1873 case ST_OACC_END_DATA
:
1874 p
= "!$ACC END DATA";
1876 case ST_OACC_HOST_DATA
:
1877 p
= "!$ACC HOST_DATA";
1879 case ST_OACC_END_HOST_DATA
:
1880 p
= "!$ACC END HOST_DATA";
1885 case ST_OACC_END_LOOP
:
1886 p
= "!$ACC END LOOP";
1888 case ST_OACC_DECLARE
:
1889 p
= "!$ACC DECLARE";
1891 case ST_OACC_UPDATE
:
1900 case ST_OACC_ENTER_DATA
:
1901 p
= "!$ACC ENTER DATA";
1903 case ST_OACC_EXIT_DATA
:
1904 p
= "!$ACC EXIT DATA";
1909 case ST_OMP_BARRIER
:
1910 p
= "!$OMP BARRIER";
1915 case ST_OMP_CANCELLATION_POINT
:
1916 p
= "!$OMP CANCELLATION POINT";
1918 case ST_OMP_CRITICAL
:
1919 p
= "!$OMP CRITICAL";
1921 case ST_OMP_DECLARE_REDUCTION
:
1922 p
= "!$OMP DECLARE REDUCTION";
1924 case ST_OMP_DECLARE_SIMD
:
1925 p
= "!$OMP DECLARE SIMD";
1927 case ST_OMP_DECLARE_TARGET
:
1928 p
= "!$OMP DECLARE TARGET";
1930 case ST_OMP_DISTRIBUTE
:
1931 p
= "!$OMP DISTRIBUTE";
1933 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
1934 p
= "!$OMP DISTRIBUTE PARALLEL DO";
1936 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1937 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1939 case ST_OMP_DISTRIBUTE_SIMD
:
1940 p
= "!$OMP DISTRIBUTE SIMD";
1945 case ST_OMP_DO_SIMD
:
1946 p
= "!$OMP DO SIMD";
1948 case ST_OMP_END_ATOMIC
:
1949 p
= "!$OMP END ATOMIC";
1951 case ST_OMP_END_CRITICAL
:
1952 p
= "!$OMP END CRITICAL";
1954 case ST_OMP_END_DISTRIBUTE
:
1955 p
= "!$OMP END DISTRIBUTE";
1957 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
1958 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
1960 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
1961 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1963 case ST_OMP_END_DISTRIBUTE_SIMD
:
1964 p
= "!$OMP END DISTRIBUTE SIMD";
1969 case ST_OMP_END_DO_SIMD
:
1970 p
= "!$OMP END DO SIMD";
1972 case ST_OMP_END_SIMD
:
1973 p
= "!$OMP END SIMD";
1975 case ST_OMP_END_MASTER
:
1976 p
= "!$OMP END MASTER";
1978 case ST_OMP_END_ORDERED
:
1979 p
= "!$OMP END ORDERED";
1981 case ST_OMP_END_PARALLEL
:
1982 p
= "!$OMP END PARALLEL";
1984 case ST_OMP_END_PARALLEL_DO
:
1985 p
= "!$OMP END PARALLEL DO";
1987 case ST_OMP_END_PARALLEL_DO_SIMD
:
1988 p
= "!$OMP END PARALLEL DO SIMD";
1990 case ST_OMP_END_PARALLEL_SECTIONS
:
1991 p
= "!$OMP END PARALLEL SECTIONS";
1993 case ST_OMP_END_PARALLEL_WORKSHARE
:
1994 p
= "!$OMP END PARALLEL WORKSHARE";
1996 case ST_OMP_END_SECTIONS
:
1997 p
= "!$OMP END SECTIONS";
1999 case ST_OMP_END_SINGLE
:
2000 p
= "!$OMP END SINGLE";
2002 case ST_OMP_END_TASK
:
2003 p
= "!$OMP END TASK";
2005 case ST_OMP_END_TARGET
:
2006 p
= "!$OMP END TARGET";
2008 case ST_OMP_END_TARGET_DATA
:
2009 p
= "!$OMP END TARGET DATA";
2011 case ST_OMP_END_TARGET_TEAMS
:
2012 p
= "!$OMP END TARGET TEAMS";
2014 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2015 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2017 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2018 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2020 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2021 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2023 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2024 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2026 case ST_OMP_END_TASKGROUP
:
2027 p
= "!$OMP END TASKGROUP";
2029 case ST_OMP_END_TEAMS
:
2030 p
= "!$OMP END TEAMS";
2032 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2033 p
= "!$OMP END TEAMS DISTRIBUTE";
2035 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2036 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2038 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2039 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2041 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2042 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2044 case ST_OMP_END_WORKSHARE
:
2045 p
= "!$OMP END WORKSHARE";
2053 case ST_OMP_ORDERED
:
2054 p
= "!$OMP ORDERED";
2056 case ST_OMP_PARALLEL
:
2057 p
= "!$OMP PARALLEL";
2059 case ST_OMP_PARALLEL_DO
:
2060 p
= "!$OMP PARALLEL DO";
2062 case ST_OMP_PARALLEL_DO_SIMD
:
2063 p
= "!$OMP PARALLEL DO SIMD";
2065 case ST_OMP_PARALLEL_SECTIONS
:
2066 p
= "!$OMP PARALLEL SECTIONS";
2068 case ST_OMP_PARALLEL_WORKSHARE
:
2069 p
= "!$OMP PARALLEL WORKSHARE";
2071 case ST_OMP_SECTIONS
:
2072 p
= "!$OMP SECTIONS";
2074 case ST_OMP_SECTION
:
2075 p
= "!$OMP SECTION";
2086 case ST_OMP_TARGET_DATA
:
2087 p
= "!$OMP TARGET DATA";
2089 case ST_OMP_TARGET_TEAMS
:
2090 p
= "!$OMP TARGET TEAMS";
2092 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2093 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2095 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2096 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2098 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2099 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2101 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2102 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2104 case ST_OMP_TARGET_UPDATE
:
2105 p
= "!$OMP TARGET UPDATE";
2110 case ST_OMP_TASKGROUP
:
2111 p
= "!$OMP TASKGROUP";
2113 case ST_OMP_TASKWAIT
:
2114 p
= "!$OMP TASKWAIT";
2116 case ST_OMP_TASKYIELD
:
2117 p
= "!$OMP TASKYIELD";
2122 case ST_OMP_TEAMS_DISTRIBUTE
:
2123 p
= "!$OMP TEAMS DISTRIBUTE";
2125 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2126 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2128 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2129 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2131 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2132 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2134 case ST_OMP_THREADPRIVATE
:
2135 p
= "!$OMP THREADPRIVATE";
2137 case ST_OMP_WORKSHARE
:
2138 p
= "!$OMP WORKSHARE";
2141 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2148 /* Create a symbol for the main program and assign it to ns->proc_name. */
2151 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2153 gfc_symbol
*main_program
;
2154 symbol_attribute attr
;
2156 gfc_get_symbol (name
, ns
, &main_program
);
2157 gfc_clear_attr (&attr
);
2158 attr
.flavor
= FL_PROGRAM
;
2159 attr
.proc
= PROC_UNKNOWN
;
2160 attr
.subroutine
= 1;
2161 attr
.access
= ACCESS_PUBLIC
;
2162 attr
.is_main_program
= 1;
2163 main_program
->attr
= attr
;
2164 main_program
->declared_at
= gfc_current_locus
;
2165 ns
->proc_name
= main_program
;
2166 gfc_commit_symbols ();
2170 /* Do whatever is necessary to accept the last statement. */
2173 accept_statement (gfc_statement st
)
2177 case ST_IMPLICIT_NONE
:
2184 gfc_current_ns
->proc_name
= gfc_new_block
;
2187 /* If the statement is the end of a block, lay down a special code
2188 that allows a branch to the end of the block from within the
2189 construct. IF and SELECT are treated differently from DO
2190 (where EXEC_NOP is added inside the loop) for two
2192 1. END DO has a meaning in the sense that after a GOTO to
2193 it, the loop counter must be increased.
2194 2. IF blocks and SELECT blocks can consist of multiple
2195 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2196 Putting the label before the END IF would make the jump
2197 from, say, the ELSE IF block to the END IF illegal. */
2201 case ST_END_CRITICAL
:
2202 if (gfc_statement_label
!= NULL
)
2204 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2209 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2210 one parallel block. Thus, we add the special code to the nested block
2211 itself, instead of the parent one. */
2213 case ST_END_ASSOCIATE
:
2214 if (gfc_statement_label
!= NULL
)
2216 new_st
.op
= EXEC_END_BLOCK
;
2221 /* The end-of-program unit statements do not get the special
2222 marker and require a statement of some sort if they are a
2225 case ST_END_PROGRAM
:
2226 case ST_END_FUNCTION
:
2227 case ST_END_SUBROUTINE
:
2228 if (gfc_statement_label
!= NULL
)
2230 new_st
.op
= EXEC_RETURN
;
2235 new_st
.op
= EXEC_END_PROCEDURE
;
2251 gfc_commit_symbols ();
2252 gfc_warning_check ();
2253 gfc_clear_new_st ();
2257 /* Undo anything tentative that has been built for the current
2261 reject_statement (void)
2263 /* Revert to the previous charlen chain. */
2264 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2265 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2267 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2268 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2270 gfc_new_block
= NULL
;
2271 gfc_undo_symbols ();
2272 gfc_clear_warning ();
2273 undo_new_statement ();
2277 /* Generic complaint about an out of order statement. We also do
2278 whatever is necessary to clean up. */
2281 unexpected_statement (gfc_statement st
)
2283 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2285 reject_statement ();
2289 /* Given the next statement seen by the matcher, make sure that it is
2290 in proper order with the last. This subroutine is initialized by
2291 calling it with an argument of ST_NONE. If there is a problem, we
2292 issue an error and return false. Otherwise we return true.
2294 Individual parsers need to verify that the statements seen are
2295 valid before calling here, i.e., ENTRY statements are not allowed in
2296 INTERFACE blocks. The following diagram is taken from the standard:
2298 +---------------------------------------+
2299 | program subroutine function module |
2300 +---------------------------------------+
2302 +---------------------------------------+
2304 +---------------------------------------+
2306 | +-----------+------------------+
2307 | | parameter | implicit |
2308 | +-----------+------------------+
2309 | format | | derived type |
2310 | entry | parameter | interface |
2311 | | data | specification |
2312 | | | statement func |
2313 | +-----------+------------------+
2314 | | data | executable |
2315 +--------+-----------+------------------+
2317 +---------------------------------------+
2318 | internal module/subprogram |
2319 +---------------------------------------+
2321 +---------------------------------------+
2330 ORDER_IMPLICIT_NONE
,
2338 enum state_order state
;
2339 gfc_statement last_statement
;
2345 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2351 p
->state
= ORDER_START
;
2355 if (p
->state
> ORDER_USE
)
2357 p
->state
= ORDER_USE
;
2361 if (p
->state
> ORDER_IMPORT
)
2363 p
->state
= ORDER_IMPORT
;
2366 case ST_IMPLICIT_NONE
:
2367 if (p
->state
> ORDER_IMPLICIT
)
2370 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2371 statement disqualifies a USE but not an IMPLICIT NONE.
2372 Duplicate IMPLICIT NONEs are caught when the implicit types
2375 p
->state
= ORDER_IMPLICIT_NONE
;
2379 if (p
->state
> ORDER_IMPLICIT
)
2381 p
->state
= ORDER_IMPLICIT
;
2386 if (p
->state
< ORDER_IMPLICIT_NONE
)
2387 p
->state
= ORDER_IMPLICIT_NONE
;
2391 if (p
->state
>= ORDER_EXEC
)
2393 if (p
->state
< ORDER_IMPLICIT
)
2394 p
->state
= ORDER_IMPLICIT
;
2398 if (p
->state
< ORDER_SPEC
)
2399 p
->state
= ORDER_SPEC
;
2404 case ST_DERIVED_DECL
:
2405 case ST_OACC_DECLARE
:
2407 if (p
->state
>= ORDER_EXEC
)
2409 if (p
->state
< ORDER_SPEC
)
2410 p
->state
= ORDER_SPEC
;
2415 if (p
->state
< ORDER_EXEC
)
2416 p
->state
= ORDER_EXEC
;
2420 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
2421 gfc_ascii_statement (st
));
2424 /* All is well, record the statement in case we need it next time. */
2425 p
->where
= gfc_current_locus
;
2426 p
->last_statement
= st
;
2431 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2432 gfc_ascii_statement (st
),
2433 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2439 /* Handle an unexpected end of file. This is a show-stopper... */
2441 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2444 unexpected_eof (void)
2448 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
2450 /* Memory cleanup. Move to "second to last". */
2451 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2454 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2457 longjmp (eof_buf
, 1);
2461 /* Parse the CONTAINS section of a derived type definition. */
2463 gfc_access gfc_typebound_default_access
;
2466 parse_derived_contains (void)
2469 bool seen_private
= false;
2470 bool seen_comps
= false;
2471 bool error_flag
= false;
2474 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2475 gcc_assert (gfc_current_block ());
2477 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2479 if (gfc_current_block ()->attr
.sequence
)
2480 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
2481 " section at %C", gfc_current_block ()->name
);
2482 if (gfc_current_block ()->attr
.is_bind_c
)
2483 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
2484 " section at %C", gfc_current_block ()->name
);
2486 accept_statement (ST_CONTAINS
);
2487 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2489 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2495 st
= next_statement ();
2503 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2507 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2510 accept_statement (ST_PROCEDURE
);
2515 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2518 accept_statement (ST_GENERIC
);
2523 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2527 accept_statement (ST_FINAL
);
2535 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2536 "at %C with empty CONTAINS section")))
2539 /* ST_END_TYPE is accepted by parse_derived after return. */
2543 if (!gfc_find_state (COMP_MODULE
))
2545 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2552 gfc_error ("PRIVATE statement at %C must precede procedure"
2559 gfc_error ("Duplicate PRIVATE statement at %C");
2563 accept_statement (ST_PRIVATE
);
2564 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2565 seen_private
= true;
2569 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2573 gfc_error ("Already inside a CONTAINS block at %C");
2577 unexpected_statement (st
);
2585 reject_statement ();
2589 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2595 /* Parse a derived type. */
2598 parse_derived (void)
2600 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2604 gfc_component
*c
, *lock_comp
= NULL
;
2606 accept_statement (ST_DERIVED_DECL
);
2607 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2609 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2616 while (compiling_type
)
2618 st
= next_statement ();
2626 accept_statement (st
);
2631 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2638 if (!seen_component
)
2639 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2640 "definition at %C without components");
2642 accept_statement (ST_END_TYPE
);
2646 if (!gfc_find_state (COMP_MODULE
))
2648 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2655 gfc_error ("PRIVATE statement at %C must precede "
2656 "structure components");
2661 gfc_error ("Duplicate PRIVATE statement at %C");
2663 s
.sym
->component_access
= ACCESS_PRIVATE
;
2665 accept_statement (ST_PRIVATE
);
2672 gfc_error ("SEQUENCE statement at %C must precede "
2673 "structure components");
2677 if (gfc_current_block ()->attr
.sequence
)
2678 gfc_warning ("SEQUENCE attribute at %C already specified in "
2683 gfc_error ("Duplicate SEQUENCE statement at %C");
2687 gfc_add_sequence (&gfc_current_block ()->attr
,
2688 gfc_current_block ()->name
, NULL
);
2692 gfc_notify_std (GFC_STD_F2003
,
2693 "CONTAINS block in derived type"
2694 " definition at %C");
2696 accept_statement (ST_CONTAINS
);
2697 parse_derived_contains ();
2701 unexpected_statement (st
);
2706 /* need to verify that all fields of the derived type are
2707 * interoperable with C if the type is declared to be bind(c)
2709 sym
= gfc_current_block ();
2710 for (c
= sym
->components
; c
; c
= c
->next
)
2712 bool coarray
, lock_type
, allocatable
, pointer
;
2713 coarray
= lock_type
= allocatable
= pointer
= false;
2715 /* Look for allocatable components. */
2716 if (c
->attr
.allocatable
2717 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2718 && CLASS_DATA (c
)->attr
.allocatable
)
2719 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2720 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2723 sym
->attr
.alloc_comp
= 1;
2726 /* Look for pointer components. */
2728 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2729 && CLASS_DATA (c
)->attr
.class_pointer
)
2730 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2733 sym
->attr
.pointer_comp
= 1;
2736 /* Look for procedure pointer components. */
2737 if (c
->attr
.proc_pointer
2738 || (c
->ts
.type
== BT_DERIVED
2739 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2740 sym
->attr
.proc_pointer_comp
= 1;
2742 /* Looking for coarray components. */
2743 if (c
->attr
.codimension
2744 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2745 && CLASS_DATA (c
)->attr
.codimension
))
2748 sym
->attr
.coarray_comp
= 1;
2751 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2752 && !c
->attr
.pointer
)
2755 sym
->attr
.coarray_comp
= 1;
2758 /* Looking for lock_type components. */
2759 if ((c
->ts
.type
== BT_DERIVED
2760 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2761 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2762 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2763 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2764 == INTMOD_ISO_FORTRAN_ENV
2765 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2766 == ISOFORTRAN_LOCK_TYPE
)
2767 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2768 && !allocatable
&& !pointer
))
2772 sym
->attr
.lock_comp
= 1;
2775 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2776 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2777 unless there are nondirect [allocatable or pointer] components
2778 involved (cf. 1.3.33.1 and 1.3.33.3). */
2780 if (pointer
&& !coarray
&& lock_type
)
2781 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2782 "codimension or be a subcomponent of a coarray, "
2783 "which is not possible as the component has the "
2784 "pointer attribute", c
->name
, &c
->loc
);
2785 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2786 && c
->ts
.u
.derived
->attr
.lock_comp
)
2787 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2788 "of type LOCK_TYPE, which must have a codimension or be a "
2789 "subcomponent of a coarray", c
->name
, &c
->loc
);
2791 if (lock_type
&& allocatable
&& !coarray
)
2792 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2793 "a codimension", c
->name
, &c
->loc
);
2794 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2795 && c
->ts
.u
.derived
->attr
.lock_comp
)
2796 gfc_error ("Allocatable component %s at %L must have a codimension as "
2797 "it has a noncoarray subcomponent of type LOCK_TYPE",
2800 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2801 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2802 "subcomponent of type LOCK_TYPE must have a codimension or "
2803 "be a subcomponent of a coarray. (Variables of type %s may "
2804 "not have a codimension as already a coarray "
2805 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2807 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2808 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2809 "subcomponent of type LOCK_TYPE must have a codimension or "
2810 "be a subcomponent of a coarray. (Variables of type %s may "
2811 "not have a codimension as %s at %L has a codimension or a "
2812 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2813 sym
->name
, c
->name
, &c
->loc
);
2815 /* Look for private components. */
2816 if (sym
->component_access
== ACCESS_PRIVATE
2817 || c
->attr
.access
== ACCESS_PRIVATE
2818 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2819 sym
->attr
.private_comp
= 1;
2822 if (!seen_component
)
2823 sym
->attr
.zero_comp
= 1;
2829 /* Parse an ENUM. */
2837 int seen_enumerator
= 0;
2839 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2843 while (compiling_enum
)
2845 st
= next_statement ();
2853 seen_enumerator
= 1;
2854 accept_statement (st
);
2859 if (!seen_enumerator
)
2860 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2861 accept_statement (st
);
2865 gfc_free_enum_history ();
2866 unexpected_statement (st
);
2874 /* Parse an interface. We must be able to deal with the possibility
2875 of recursive interfaces. The parse_spec() subroutine is mutually
2876 recursive with parse_interface(). */
2878 static gfc_statement
parse_spec (gfc_statement
);
2881 parse_interface (void)
2883 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2884 gfc_symbol
*prog_unit
, *sym
;
2885 gfc_interface_info save
;
2886 gfc_state_data s1
, s2
;
2889 accept_statement (ST_INTERFACE
);
2891 current_interface
.ns
= gfc_current_ns
;
2892 save
= current_interface
;
2894 sym
= (current_interface
.type
== INTERFACE_GENERIC
2895 || current_interface
.type
== INTERFACE_USER_OP
)
2896 ? gfc_new_block
: NULL
;
2898 push_state (&s1
, COMP_INTERFACE
, sym
);
2899 current_state
= COMP_NONE
;
2902 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2904 st
= next_statement ();
2912 if (st
== ST_SUBROUTINE
)
2913 new_state
= COMP_SUBROUTINE
;
2914 else if (st
== ST_FUNCTION
)
2915 new_state
= COMP_FUNCTION
;
2916 if (gfc_new_block
->attr
.pointer
)
2918 gfc_new_block
->attr
.pointer
= 0;
2919 gfc_new_block
->attr
.proc_pointer
= 1;
2921 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2922 gfc_new_block
->formal
, NULL
))
2924 reject_statement ();
2925 gfc_free_namespace (gfc_current_ns
);
2931 case ST_MODULE_PROC
: /* The module procedure matcher makes
2932 sure the context is correct. */
2933 accept_statement (st
);
2934 gfc_free_namespace (gfc_current_ns
);
2937 case ST_END_INTERFACE
:
2938 gfc_free_namespace (gfc_current_ns
);
2939 gfc_current_ns
= current_interface
.ns
;
2943 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2944 gfc_ascii_statement (st
));
2945 reject_statement ();
2946 gfc_free_namespace (gfc_current_ns
);
2951 /* Make sure that the generic name has the right attribute. */
2952 if (current_interface
.type
== INTERFACE_GENERIC
2953 && current_state
== COMP_NONE
)
2955 if (new_state
== COMP_FUNCTION
&& sym
)
2956 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2957 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2958 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2960 current_state
= new_state
;
2963 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2965 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2966 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2967 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2968 "cannot be the same as an intrinsic type",
2969 gfc_new_block
->name
);
2972 push_state (&s2
, new_state
, gfc_new_block
);
2973 accept_statement (st
);
2974 prog_unit
= gfc_new_block
;
2975 prog_unit
->formal_ns
= gfc_current_ns
;
2976 if (prog_unit
== prog_unit
->formal_ns
->proc_name
2977 && prog_unit
->ns
!= prog_unit
->formal_ns
)
2981 /* Read data declaration statements. */
2982 st
= parse_spec (ST_NONE
);
2984 /* Since the interface block does not permit an IMPLICIT statement,
2985 the default type for the function or the result must be taken
2986 from the formal namespace. */
2987 if (new_state
== COMP_FUNCTION
)
2989 if (prog_unit
->result
== prog_unit
2990 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2991 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2992 else if (prog_unit
->result
!= prog_unit
2993 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
2994 gfc_set_default_type (prog_unit
->result
, 1,
2995 prog_unit
->formal_ns
);
2998 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3000 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3001 gfc_ascii_statement (st
));
3002 reject_statement ();
3006 /* Add EXTERNAL attribute to function or subroutine. */
3007 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3008 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3010 current_interface
= save
;
3011 gfc_add_interface (prog_unit
);
3014 if (current_interface
.ns
3015 && current_interface
.ns
->proc_name
3016 && strcmp (current_interface
.ns
->proc_name
->name
,
3017 prog_unit
->name
) == 0)
3018 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
3019 "enclosing procedure", prog_unit
->name
,
3020 ¤t_interface
.ns
->proc_name
->declared_at
);
3029 /* Associate function characteristics by going back to the function
3030 declaration and rematching the prefix. */
3033 match_deferred_characteristics (gfc_typespec
* ts
)
3036 match m
= MATCH_ERROR
;
3037 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3039 loc
= gfc_current_locus
;
3041 gfc_current_locus
= gfc_current_block ()->declared_at
;
3044 gfc_buffer_error (1);
3045 m
= gfc_match_prefix (ts
);
3046 gfc_buffer_error (0);
3048 if (ts
->type
== BT_DERIVED
)
3056 /* Only permit one go at the characteristic association. */
3060 /* Set the function locus correctly. If we have not found the
3061 function name, there is an error. */
3063 && gfc_match ("function% %n", name
) == MATCH_YES
3064 && strcmp (name
, gfc_current_block ()->name
) == 0)
3066 gfc_current_block ()->declared_at
= gfc_current_locus
;
3067 gfc_commit_symbols ();
3072 gfc_undo_symbols ();
3075 gfc_current_locus
=loc
;
3080 /* Check specification-expressions in the function result of the currently
3081 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3082 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3083 scope are not yet parsed so this has to be delayed up to parse_spec. */
3086 check_function_result_typed (void)
3088 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
3090 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3091 gcc_assert (ts
->type
!= BT_UNKNOWN
);
3093 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3094 /* TODO: Extend when KIND type parameters are implemented. */
3095 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
3096 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
3100 /* Parse a set of specification statements. Returns the statement
3101 that doesn't fit. */
3103 static gfc_statement
3104 parse_spec (gfc_statement st
)
3107 bool function_result_typed
= false;
3108 bool bad_characteristic
= false;
3111 verify_st_order (&ss
, ST_NONE
, false);
3113 st
= next_statement ();
3115 /* If we are not inside a function or don't have a result specified so far,
3116 do nothing special about it. */
3117 if (gfc_current_state () != COMP_FUNCTION
)
3118 function_result_typed
= true;
3121 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3124 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3125 function_result_typed
= true;
3130 /* If we're inside a BLOCK construct, some statements are disallowed.
3131 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3132 or VALUE are also disallowed, but they don't have a particular ST_*
3133 key so we have to check for them individually in their matcher routine. */
3134 if (gfc_current_state () == COMP_BLOCK
)
3138 case ST_IMPLICIT_NONE
:
3141 case ST_EQUIVALENCE
:
3142 case ST_STATEMENT_FUNCTION
:
3143 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3144 gfc_ascii_statement (st
));
3145 reject_statement ();
3151 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3152 /* Fortran 2008, C1116. */
3159 case ST_END_BLOCK_DATA
:
3161 case ST_EQUIVALENCE
:
3164 case ST_IMPLICIT_NONE
:
3165 case ST_DERIVED_DECL
:
3173 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3174 gfc_ascii_statement (st
));
3175 reject_statement ();
3179 /* If we find a statement that can not be followed by an IMPLICIT statement
3180 (and thus we can expect to see none any further), type the function result
3181 if it has not yet been typed. Be careful not to give the END statement
3182 to verify_st_order! */
3183 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3185 bool verify_now
= false;
3187 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3192 verify_st_order (&dummyss
, ST_NONE
, false);
3193 verify_st_order (&dummyss
, st
, false);
3195 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3201 check_function_result_typed ();
3202 function_result_typed
= true;
3211 case ST_IMPLICIT_NONE
:
3213 if (!function_result_typed
)
3215 check_function_result_typed ();
3216 function_result_typed
= true;
3222 case ST_DATA
: /* Not allowed in interfaces */
3223 if (gfc_current_state () == COMP_INTERFACE
)
3233 case ST_DERIVED_DECL
:
3236 if (!verify_st_order (&ss
, st
, false))
3238 reject_statement ();
3239 st
= next_statement ();
3249 case ST_DERIVED_DECL
:
3255 if (gfc_current_state () != COMP_MODULE
)
3257 gfc_error ("%s statement must appear in a MODULE",
3258 gfc_ascii_statement (st
));
3259 reject_statement ();
3263 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3265 gfc_error ("%s statement at %C follows another accessibility "
3266 "specification", gfc_ascii_statement (st
));
3267 reject_statement ();
3271 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3272 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3276 case ST_STATEMENT_FUNCTION
:
3277 if (gfc_current_state () == COMP_MODULE
)
3279 unexpected_statement (st
);
3287 accept_statement (st
);
3288 st
= next_statement ();
3292 accept_statement (st
);
3294 st
= next_statement ();
3297 case ST_GET_FCN_CHARACTERISTICS
:
3298 /* This statement triggers the association of a function's result
3300 ts
= &gfc_current_block ()->result
->ts
;
3301 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3302 bad_characteristic
= true;
3304 st
= next_statement ();
3307 case ST_OACC_DECLARE
:
3308 if (!verify_st_order(&ss
, st
, false))
3310 reject_statement ();
3311 st
= next_statement ();
3314 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3315 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3316 accept_statement (st
);
3317 st
= next_statement ();
3324 /* If match_deferred_characteristics failed, then there is an error. */
3325 if (bad_characteristic
)
3327 ts
= &gfc_current_block ()->result
->ts
;
3328 if (ts
->type
!= BT_DERIVED
)
3329 gfc_error ("Bad kind expression for function '%s' at %L",
3330 gfc_current_block ()->name
,
3331 &gfc_current_block ()->declared_at
);
3333 gfc_error ("The type for function '%s' at %L is not accessible",
3334 gfc_current_block ()->name
,
3335 &gfc_current_block ()->declared_at
);
3337 gfc_current_block ()->ts
.kind
= 0;
3338 /* Keep the derived type; if it's bad, it will be discovered later. */
3339 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3340 ts
->type
= BT_UNKNOWN
;
3347 /* Parse a WHERE block, (not a simple WHERE statement). */
3350 parse_where_block (void)
3352 int seen_empty_else
;
3357 accept_statement (ST_WHERE_BLOCK
);
3358 top
= gfc_state_stack
->tail
;
3360 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3362 d
= add_statement ();
3363 d
->expr1
= top
->expr1
;
3369 seen_empty_else
= 0;
3373 st
= next_statement ();
3379 case ST_WHERE_BLOCK
:
3380 parse_where_block ();
3385 accept_statement (st
);
3389 if (seen_empty_else
)
3391 gfc_error ("ELSEWHERE statement at %C follows previous "
3392 "unmasked ELSEWHERE");
3393 reject_statement ();
3397 if (new_st
.expr1
== NULL
)
3398 seen_empty_else
= 1;
3400 d
= new_level (gfc_state_stack
->head
);
3402 d
->expr1
= new_st
.expr1
;
3404 accept_statement (st
);
3409 accept_statement (st
);
3413 gfc_error ("Unexpected %s statement in WHERE block at %C",
3414 gfc_ascii_statement (st
));
3415 reject_statement ();
3419 while (st
!= ST_END_WHERE
);
3425 /* Parse a FORALL block (not a simple FORALL statement). */
3428 parse_forall_block (void)
3434 accept_statement (ST_FORALL_BLOCK
);
3435 top
= gfc_state_stack
->tail
;
3437 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3439 d
= add_statement ();
3440 d
->op
= EXEC_FORALL
;
3445 st
= next_statement ();
3450 case ST_POINTER_ASSIGNMENT
:
3453 accept_statement (st
);
3456 case ST_WHERE_BLOCK
:
3457 parse_where_block ();
3460 case ST_FORALL_BLOCK
:
3461 parse_forall_block ();
3465 accept_statement (st
);
3472 gfc_error ("Unexpected %s statement in FORALL block at %C",
3473 gfc_ascii_statement (st
));
3475 reject_statement ();
3479 while (st
!= ST_END_FORALL
);
3485 static gfc_statement
parse_executable (gfc_statement
);
3487 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3490 parse_if_block (void)
3499 accept_statement (ST_IF_BLOCK
);
3501 top
= gfc_state_stack
->tail
;
3502 push_state (&s
, COMP_IF
, gfc_new_block
);
3504 new_st
.op
= EXEC_IF
;
3505 d
= add_statement ();
3507 d
->expr1
= top
->expr1
;
3513 st
= parse_executable (ST_NONE
);
3523 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3524 "statement at %L", &else_locus
);
3526 reject_statement ();
3530 d
= new_level (gfc_state_stack
->head
);
3532 d
->expr1
= new_st
.expr1
;
3534 accept_statement (st
);
3541 gfc_error ("Duplicate ELSE statements at %L and %C",
3543 reject_statement ();
3548 else_locus
= gfc_current_locus
;
3550 d
= new_level (gfc_state_stack
->head
);
3553 accept_statement (st
);
3561 unexpected_statement (st
);
3565 while (st
!= ST_ENDIF
);
3568 accept_statement (st
);
3572 /* Parse a SELECT block. */
3575 parse_select_block (void)
3581 accept_statement (ST_SELECT_CASE
);
3583 cp
= gfc_state_stack
->tail
;
3584 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3586 /* Make sure that the next statement is a CASE or END SELECT. */
3589 st
= next_statement ();
3592 if (st
== ST_END_SELECT
)
3594 /* Empty SELECT CASE is OK. */
3595 accept_statement (st
);
3602 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3605 reject_statement ();
3608 /* At this point, we're got a nonempty select block. */
3609 cp
= new_level (cp
);
3612 accept_statement (st
);
3616 st
= parse_executable (ST_NONE
);
3623 cp
= new_level (gfc_state_stack
->head
);
3625 gfc_clear_new_st ();
3627 accept_statement (st
);
3633 /* Can't have an executable statement because of
3634 parse_executable(). */
3636 unexpected_statement (st
);
3640 while (st
!= ST_END_SELECT
);
3643 accept_statement (st
);
3647 /* Pop the current selector from the SELECT TYPE stack. */
3650 select_type_pop (void)
3652 gfc_select_type_stack
*old
= select_type_stack
;
3653 select_type_stack
= old
->prev
;
3658 /* Parse a SELECT TYPE construct (F03:R821). */
3661 parse_select_type_block (void)
3667 accept_statement (ST_SELECT_TYPE
);
3669 cp
= gfc_state_stack
->tail
;
3670 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3672 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3676 st
= next_statement ();
3679 if (st
== ST_END_SELECT
)
3680 /* Empty SELECT CASE is OK. */
3682 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3685 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3686 "following SELECT TYPE at %C");
3688 reject_statement ();
3691 /* At this point, we're got a nonempty select block. */
3692 cp
= new_level (cp
);
3695 accept_statement (st
);
3699 st
= parse_executable (ST_NONE
);
3707 cp
= new_level (gfc_state_stack
->head
);
3709 gfc_clear_new_st ();
3711 accept_statement (st
);
3717 /* Can't have an executable statement because of
3718 parse_executable(). */
3720 unexpected_statement (st
);
3724 while (st
!= ST_END_SELECT
);
3728 accept_statement (st
);
3729 gfc_current_ns
= gfc_current_ns
->parent
;
3734 /* Given a symbol, make sure it is not an iteration variable for a DO
3735 statement. This subroutine is called when the symbol is seen in a
3736 context that causes it to become redefined. If the symbol is an
3737 iterator, we generate an error message and return nonzero. */
3740 gfc_check_do_variable (gfc_symtree
*st
)
3744 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3745 if (s
->do_variable
== st
)
3747 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3748 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3756 /* Checks to see if the current statement label closes an enddo.
3757 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3758 an error) if it incorrectly closes an ENDDO. */
3761 check_do_closure (void)
3765 if (gfc_statement_label
== NULL
)
3768 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3769 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3773 return 0; /* No loops to close */
3775 if (p
->ext
.end_do_label
== gfc_statement_label
)
3777 if (p
== gfc_state_stack
)
3780 gfc_error ("End of nonblock DO statement at %C is within another block");
3784 /* At this point, the label doesn't terminate the innermost loop.
3785 Make sure it doesn't terminate another one. */
3786 for (; p
; p
= p
->previous
)
3787 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3788 && p
->ext
.end_do_label
== gfc_statement_label
)
3790 gfc_error ("End of nonblock DO statement at %C is interwoven "
3791 "with another DO loop");
3799 /* Parse a series of contained program units. */
3801 static void parse_progunit (gfc_statement
);
3804 /* Parse a CRITICAL block. */
3807 parse_critical_block (void)
3810 gfc_state_data s
, *sd
;
3813 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3814 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3815 gfc_error_now ("CRITICAL block inside of OpenMP or OpenACC region at %C");
3817 s
.ext
.end_do_label
= new_st
.label1
;
3819 accept_statement (ST_CRITICAL
);
3820 top
= gfc_state_stack
->tail
;
3822 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3824 d
= add_statement ();
3825 d
->op
= EXEC_CRITICAL
;
3830 st
= parse_executable (ST_NONE
);
3838 case ST_END_CRITICAL
:
3839 if (s
.ext
.end_do_label
!= NULL
3840 && s
.ext
.end_do_label
!= gfc_statement_label
)
3841 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3842 "match CRITICAL label");
3844 if (gfc_statement_label
!= NULL
)
3846 new_st
.op
= EXEC_NOP
;
3852 unexpected_statement (st
);
3856 while (st
!= ST_END_CRITICAL
);
3859 accept_statement (st
);
3863 /* Set up the local namespace for a BLOCK construct. */
3866 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3868 gfc_namespace
* my_ns
;
3869 static int numblock
= 1;
3871 my_ns
= gfc_get_namespace (parent_ns
, 1);
3872 my_ns
->construct_entities
= 1;
3874 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3875 code generation (so it must not be NULL).
3876 We set its recursive argument if our container procedure is recursive, so
3877 that local variables are accordingly placed on the stack when it
3878 will be necessary. */
3880 my_ns
->proc_name
= gfc_new_block
;
3884 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3886 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3887 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3888 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3889 my_ns
->proc_name
->name
, NULL
);
3891 gfc_commit_symbol (my_ns
->proc_name
);
3894 if (parent_ns
->proc_name
)
3895 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3901 /* Parse a BLOCK construct. */
3904 parse_block_construct (void)
3906 gfc_namespace
* my_ns
;
3909 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3911 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3913 new_st
.op
= EXEC_BLOCK
;
3914 new_st
.ext
.block
.ns
= my_ns
;
3915 new_st
.ext
.block
.assoc
= NULL
;
3916 accept_statement (ST_BLOCK
);
3918 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3919 gfc_current_ns
= my_ns
;
3921 parse_progunit (ST_NONE
);
3923 gfc_current_ns
= gfc_current_ns
->parent
;
3928 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3929 behind the scenes with compiler-generated variables. */
3932 parse_associate (void)
3934 gfc_namespace
* my_ns
;
3937 gfc_association_list
* a
;
3939 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3941 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3943 new_st
.op
= EXEC_BLOCK
;
3944 new_st
.ext
.block
.ns
= my_ns
;
3945 gcc_assert (new_st
.ext
.block
.assoc
);
3947 /* Add all associate-names as BLOCK variables. Creating them is enough
3948 for now, they'll get their values during trans-* phase. */
3949 gfc_current_ns
= my_ns
;
3950 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3954 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3958 sym
->attr
.flavor
= FL_VARIABLE
;
3960 sym
->declared_at
= a
->where
;
3961 gfc_set_sym_referenced (sym
);
3963 /* Initialize the typespec. It is not available in all cases,
3964 however, as it may only be set on the target during resolution.
3965 Still, sometimes it helps to have it right now -- especially
3966 for parsing component references on the associate-name
3967 in case of association to a derived-type. */
3968 sym
->ts
= a
->target
->ts
;
3971 accept_statement (ST_ASSOCIATE
);
3972 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
3975 st
= parse_executable (ST_NONE
);
3982 accept_statement (st
);
3983 my_ns
->code
= gfc_state_stack
->head
;
3987 unexpected_statement (st
);
3991 gfc_current_ns
= gfc_current_ns
->parent
;
3996 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
3997 handled inside of parse_executable(), because they aren't really
4001 parse_do_block (void)
4010 s
.ext
.end_do_label
= new_st
.label1
;
4012 if (new_st
.ext
.iterator
!= NULL
)
4013 stree
= new_st
.ext
.iterator
->var
->symtree
;
4017 accept_statement (ST_DO
);
4019 top
= gfc_state_stack
->tail
;
4020 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4023 s
.do_variable
= stree
;
4025 top
->block
= new_level (top
);
4026 top
->block
->op
= EXEC_DO
;
4029 st
= parse_executable (ST_NONE
);
4037 if (s
.ext
.end_do_label
!= NULL
4038 && s
.ext
.end_do_label
!= gfc_statement_label
)
4039 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4042 if (gfc_statement_label
!= NULL
)
4044 new_st
.op
= EXEC_NOP
;
4049 case ST_IMPLIED_ENDDO
:
4050 /* If the do-stmt of this DO construct has a do-construct-name,
4051 the corresponding end-do must be an end-do-stmt (with a matching
4052 name, but in that case we must have seen ST_ENDDO first).
4053 We only complain about this in pedantic mode. */
4054 if (gfc_current_block () != NULL
)
4055 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4056 &gfc_current_block()->declared_at
);
4061 unexpected_statement (st
);
4066 accept_statement (st
);
4070 /* Parse the statements of OpenMP do/parallel do. */
4072 static gfc_statement
4073 parse_omp_do (gfc_statement omp_st
)
4079 accept_statement (omp_st
);
4081 cp
= gfc_state_stack
->tail
;
4082 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4083 np
= new_level (cp
);
4089 st
= next_statement ();
4092 else if (st
== ST_DO
)
4095 unexpected_statement (st
);
4099 if (gfc_statement_label
!= NULL
4100 && gfc_state_stack
->previous
!= NULL
4101 && gfc_state_stack
->previous
->state
== COMP_DO
4102 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4110 there should be no !$OMP END DO. */
4112 return ST_IMPLIED_ENDDO
;
4115 check_do_closure ();
4118 st
= next_statement ();
4119 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4122 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4123 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4124 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4126 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4127 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4129 case ST_OMP_DISTRIBUTE_SIMD
:
4130 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4132 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4133 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4134 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4135 case ST_OMP_PARALLEL_DO_SIMD
:
4136 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4138 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4139 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4140 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4142 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4143 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4145 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4146 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4148 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4149 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4151 case ST_OMP_TEAMS_DISTRIBUTE
:
4152 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4154 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4155 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4157 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4158 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4160 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4161 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4163 default: gcc_unreachable ();
4165 if (st
== omp_end_st
)
4167 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4168 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4170 gcc_assert (new_st
.op
== EXEC_NOP
);
4171 gfc_clear_new_st ();
4172 gfc_commit_symbols ();
4173 gfc_warning_check ();
4174 st
= next_statement ();
4180 /* Parse the statements of OpenMP atomic directive. */
4182 static gfc_statement
4183 parse_omp_atomic (void)
4190 accept_statement (ST_OMP_ATOMIC
);
4192 cp
= gfc_state_stack
->tail
;
4193 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4194 np
= new_level (cp
);
4197 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4198 == GFC_OMP_ATOMIC_CAPTURE
);
4202 st
= next_statement ();
4205 else if (st
== ST_ASSIGNMENT
)
4207 accept_statement (st
);
4211 unexpected_statement (st
);
4216 st
= next_statement ();
4217 if (st
== ST_OMP_END_ATOMIC
)
4219 gfc_clear_new_st ();
4220 gfc_commit_symbols ();
4221 gfc_warning_check ();
4222 st
= next_statement ();
4224 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4225 == GFC_OMP_ATOMIC_CAPTURE
)
4226 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4231 /* Parse the statements of an OpenACC structured block. */
4234 parse_oacc_structured_block (gfc_statement acc_st
)
4236 gfc_statement st
, acc_end_st
;
4238 gfc_state_data s
, *sd
;
4240 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4241 if (sd
->state
== COMP_CRITICAL
)
4242 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4244 accept_statement (acc_st
);
4246 cp
= gfc_state_stack
->tail
;
4247 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4248 np
= new_level (cp
);
4253 case ST_OACC_PARALLEL
:
4254 acc_end_st
= ST_OACC_END_PARALLEL
;
4256 case ST_OACC_KERNELS
:
4257 acc_end_st
= ST_OACC_END_KERNELS
;
4260 acc_end_st
= ST_OACC_END_DATA
;
4262 case ST_OACC_HOST_DATA
:
4263 acc_end_st
= ST_OACC_END_HOST_DATA
;
4271 st
= parse_executable (ST_NONE
);
4274 else if (st
!= acc_end_st
)
4275 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4276 reject_statement ();
4278 while (st
!= acc_end_st
);
4280 gcc_assert (new_st
.op
== EXEC_NOP
);
4282 gfc_clear_new_st ();
4283 gfc_commit_symbols ();
4284 gfc_warning_check ();
4288 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4290 static gfc_statement
4291 parse_oacc_loop (gfc_statement acc_st
)
4295 gfc_state_data s
, *sd
;
4297 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4298 if (sd
->state
== COMP_CRITICAL
)
4299 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4301 accept_statement (acc_st
);
4303 cp
= gfc_state_stack
->tail
;
4304 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4305 np
= new_level (cp
);
4311 st
= next_statement ();
4314 else if (st
== ST_DO
)
4318 gfc_error ("Expected DO loop at %C");
4319 reject_statement ();
4324 if (gfc_statement_label
!= NULL
4325 && gfc_state_stack
->previous
!= NULL
4326 && gfc_state_stack
->previous
->state
== COMP_DO
4327 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4330 return ST_IMPLIED_ENDDO
;
4333 check_do_closure ();
4336 st
= next_statement ();
4337 if (st
== ST_OACC_END_LOOP
)
4338 gfc_warning ("Redundant !$ACC END LOOP at %C");
4339 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4340 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4341 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4343 gcc_assert (new_st
.op
== EXEC_NOP
);
4344 gfc_clear_new_st ();
4345 gfc_commit_symbols ();
4346 gfc_warning_check ();
4347 st
= next_statement ();
4353 /* Parse the statements of an OpenMP structured block. */
4356 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4358 gfc_statement st
, omp_end_st
;
4362 accept_statement (omp_st
);
4364 cp
= gfc_state_stack
->tail
;
4365 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4366 np
= new_level (cp
);
4372 case ST_OMP_PARALLEL
:
4373 omp_end_st
= ST_OMP_END_PARALLEL
;
4375 case ST_OMP_PARALLEL_SECTIONS
:
4376 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4378 case ST_OMP_SECTIONS
:
4379 omp_end_st
= ST_OMP_END_SECTIONS
;
4381 case ST_OMP_ORDERED
:
4382 omp_end_st
= ST_OMP_END_ORDERED
;
4384 case ST_OMP_CRITICAL
:
4385 omp_end_st
= ST_OMP_END_CRITICAL
;
4388 omp_end_st
= ST_OMP_END_MASTER
;
4391 omp_end_st
= ST_OMP_END_SINGLE
;
4394 omp_end_st
= ST_OMP_END_TARGET
;
4396 case ST_OMP_TARGET_DATA
:
4397 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4399 case ST_OMP_TARGET_TEAMS
:
4400 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4402 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4403 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4405 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4406 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4408 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4409 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4411 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4412 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4415 omp_end_st
= ST_OMP_END_TASK
;
4417 case ST_OMP_TASKGROUP
:
4418 omp_end_st
= ST_OMP_END_TASKGROUP
;
4421 omp_end_st
= ST_OMP_END_TEAMS
;
4423 case ST_OMP_TEAMS_DISTRIBUTE
:
4424 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4426 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4427 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4429 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4430 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4432 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4433 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4435 case ST_OMP_DISTRIBUTE
:
4436 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4438 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4439 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4441 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4442 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4444 case ST_OMP_DISTRIBUTE_SIMD
:
4445 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4447 case ST_OMP_WORKSHARE
:
4448 omp_end_st
= ST_OMP_END_WORKSHARE
;
4450 case ST_OMP_PARALLEL_WORKSHARE
:
4451 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4459 if (workshare_stmts_only
)
4461 /* Inside of !$omp workshare, only
4464 where statements and constructs
4465 forall statements and constructs
4469 are allowed. For !$omp critical these
4470 restrictions apply recursively. */
4473 st
= next_statement ();
4484 accept_statement (st
);
4487 case ST_WHERE_BLOCK
:
4488 parse_where_block ();
4491 case ST_FORALL_BLOCK
:
4492 parse_forall_block ();
4495 case ST_OMP_PARALLEL
:
4496 case ST_OMP_PARALLEL_SECTIONS
:
4497 parse_omp_structured_block (st
, false);
4500 case ST_OMP_PARALLEL_WORKSHARE
:
4501 case ST_OMP_CRITICAL
:
4502 parse_omp_structured_block (st
, true);
4505 case ST_OMP_PARALLEL_DO
:
4506 case ST_OMP_PARALLEL_DO_SIMD
:
4507 st
= parse_omp_do (st
);
4511 st
= parse_omp_atomic ();
4522 st
= next_statement ();
4526 st
= parse_executable (ST_NONE
);
4529 else if (st
== ST_OMP_SECTION
4530 && (omp_st
== ST_OMP_SECTIONS
4531 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4533 np
= new_level (np
);
4537 else if (st
!= omp_end_st
)
4538 unexpected_statement (st
);
4540 while (st
!= omp_end_st
);
4544 case EXEC_OMP_END_NOWAIT
:
4545 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4547 case EXEC_OMP_CRITICAL
:
4548 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4549 || (new_st
.ext
.omp_name
!= NULL
4550 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4551 gfc_error ("Name after !$omp critical and !$omp end critical does "
4553 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4555 case EXEC_OMP_END_SINGLE
:
4556 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4557 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4558 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4559 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4567 gfc_clear_new_st ();
4568 gfc_commit_symbols ();
4569 gfc_warning_check ();
4574 /* Accept a series of executable statements. We return the first
4575 statement that doesn't fit to the caller. Any block statements are
4576 passed on to the correct handler, which usually passes the buck
4579 static gfc_statement
4580 parse_executable (gfc_statement st
)
4585 st
= next_statement ();
4589 close_flag
= check_do_closure ();
4594 case ST_END_PROGRAM
:
4597 case ST_END_FUNCTION
:
4602 case ST_END_SUBROUTINE
:
4607 case ST_SELECT_CASE
:
4608 gfc_error ("%s statement at %C cannot terminate a non-block "
4609 "DO loop", gfc_ascii_statement (st
));
4622 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4623 "first executable statement");
4629 accept_statement (st
);
4630 if (close_flag
== 1)
4631 return ST_IMPLIED_ENDDO
;
4635 parse_block_construct ();
4646 case ST_SELECT_CASE
:
4647 parse_select_block ();
4650 case ST_SELECT_TYPE
:
4651 parse_select_type_block();
4656 if (check_do_closure () == 1)
4657 return ST_IMPLIED_ENDDO
;
4661 parse_critical_block ();
4664 case ST_WHERE_BLOCK
:
4665 parse_where_block ();
4668 case ST_FORALL_BLOCK
:
4669 parse_forall_block ();
4672 case ST_OACC_PARALLEL_LOOP
:
4673 case ST_OACC_KERNELS_LOOP
:
4675 st
= parse_oacc_loop (st
);
4676 if (st
== ST_IMPLIED_ENDDO
)
4680 case ST_OACC_PARALLEL
:
4681 case ST_OACC_KERNELS
:
4683 case ST_OACC_HOST_DATA
:
4684 parse_oacc_structured_block (st
);
4687 case ST_OMP_PARALLEL
:
4688 case ST_OMP_PARALLEL_SECTIONS
:
4689 case ST_OMP_SECTIONS
:
4690 case ST_OMP_ORDERED
:
4691 case ST_OMP_CRITICAL
:
4695 case ST_OMP_TARGET_DATA
:
4696 case ST_OMP_TARGET_TEAMS
:
4699 case ST_OMP_TASKGROUP
:
4700 parse_omp_structured_block (st
, false);
4703 case ST_OMP_WORKSHARE
:
4704 case ST_OMP_PARALLEL_WORKSHARE
:
4705 parse_omp_structured_block (st
, true);
4708 case ST_OMP_DISTRIBUTE
:
4709 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4710 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4711 case ST_OMP_DISTRIBUTE_SIMD
:
4713 case ST_OMP_DO_SIMD
:
4714 case ST_OMP_PARALLEL_DO
:
4715 case ST_OMP_PARALLEL_DO_SIMD
:
4717 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4718 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4719 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4720 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4721 case ST_OMP_TEAMS_DISTRIBUTE
:
4722 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4723 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4724 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4725 st
= parse_omp_do (st
);
4726 if (st
== ST_IMPLIED_ENDDO
)
4731 st
= parse_omp_atomic ();
4738 st
= next_statement ();
4743 /* Fix the symbols for sibling functions. These are incorrectly added to
4744 the child namespace as the parser didn't know about this procedure. */
4747 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4751 gfc_symbol
*old_sym
;
4753 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4755 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4757 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4758 goto fixup_contained
;
4760 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4761 && sym
->attr
.generic
&& sym
->attr
.function
)
4762 ||(sym
->attr
.flavor
== FL_DERIVED
4763 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4764 goto fixup_contained
;
4766 old_sym
= st
->n
.sym
;
4767 if (old_sym
->ns
== ns
4768 && !old_sym
->attr
.contained
4770 /* By 14.6.1.3, host association should be excluded
4771 for the following. */
4772 && !(old_sym
->attr
.external
4773 || (old_sym
->ts
.type
!= BT_UNKNOWN
4774 && !old_sym
->attr
.implicit_type
)
4775 || old_sym
->attr
.flavor
== FL_PARAMETER
4776 || old_sym
->attr
.use_assoc
4777 || old_sym
->attr
.in_common
4778 || old_sym
->attr
.in_equivalence
4779 || old_sym
->attr
.data
4780 || old_sym
->attr
.dummy
4781 || old_sym
->attr
.result
4782 || old_sym
->attr
.dimension
4783 || old_sym
->attr
.allocatable
4784 || old_sym
->attr
.intrinsic
4785 || old_sym
->attr
.generic
4786 || old_sym
->attr
.flavor
== FL_NAMELIST
4787 || old_sym
->attr
.flavor
== FL_LABEL
4788 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4790 /* Replace it with the symbol from the parent namespace. */
4794 gfc_release_symbol (old_sym
);
4798 /* Do the same for any contained procedures. */
4799 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4804 parse_contained (int module
)
4806 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4807 gfc_state_data s1
, s2
;
4811 int contains_statements
= 0;
4814 push_state (&s1
, COMP_CONTAINS
, NULL
);
4815 parent_ns
= gfc_current_ns
;
4819 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4821 gfc_current_ns
->sibling
= parent_ns
->contained
;
4822 parent_ns
->contained
= gfc_current_ns
;
4825 /* Process the next available statement. We come here if we got an error
4826 and rejected the last statement. */
4827 st
= next_statement ();
4836 contains_statements
= 1;
4837 accept_statement (st
);
4840 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4843 /* For internal procedures, create/update the symbol in the
4844 parent namespace. */
4848 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4849 gfc_error ("Contained procedure '%s' at %C is already "
4850 "ambiguous", gfc_new_block
->name
);
4853 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4855 &gfc_new_block
->declared_at
))
4857 if (st
== ST_FUNCTION
)
4858 gfc_add_function (&sym
->attr
, sym
->name
,
4859 &gfc_new_block
->declared_at
);
4861 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4862 &gfc_new_block
->declared_at
);
4866 gfc_commit_symbols ();
4869 sym
= gfc_new_block
;
4871 /* Mark this as a contained function, so it isn't replaced
4872 by other module functions. */
4873 sym
->attr
.contained
= 1;
4875 /* Set implicit_pure so that it can be reset if any of the
4876 tests for purity fail. This is used for some optimisation
4877 during translation. */
4878 if (!sym
->attr
.pure
)
4879 sym
->attr
.implicit_pure
= 1;
4881 parse_progunit (ST_NONE
);
4883 /* Fix up any sibling functions that refer to this one. */
4884 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4885 /* Or refer to any of its alternate entry points. */
4886 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4887 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4889 gfc_current_ns
->code
= s2
.head
;
4890 gfc_current_ns
= parent_ns
;
4895 /* These statements are associated with the end of the host unit. */
4896 case ST_END_FUNCTION
:
4898 case ST_END_PROGRAM
:
4899 case ST_END_SUBROUTINE
:
4900 accept_statement (st
);
4901 gfc_current_ns
->code
= s1
.head
;
4905 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4906 gfc_ascii_statement (st
));
4907 reject_statement ();
4913 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
4914 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
4916 /* The first namespace in the list is guaranteed to not have
4917 anything (worthwhile) in it. */
4918 tmp
= gfc_current_ns
;
4919 gfc_current_ns
= parent_ns
;
4920 if (seen_error
&& tmp
->refs
> 1)
4921 gfc_free_namespace (tmp
);
4923 ns
= gfc_current_ns
->contained
;
4924 gfc_current_ns
->contained
= ns
->sibling
;
4925 gfc_free_namespace (ns
);
4928 if (!contains_statements
)
4929 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
4930 "FUNCTION or SUBROUTINE statement at %C");
4934 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4937 parse_progunit (gfc_statement st
)
4942 st
= parse_spec (st
);
4949 /* This is not allowed within BLOCK! */
4950 if (gfc_current_state () != COMP_BLOCK
)
4955 accept_statement (st
);
4962 if (gfc_current_state () == COMP_FUNCTION
)
4963 gfc_check_function_type (gfc_current_ns
);
4968 st
= parse_executable (st
);
4976 /* This is not allowed within BLOCK! */
4977 if (gfc_current_state () != COMP_BLOCK
)
4982 accept_statement (st
);
4989 unexpected_statement (st
);
4990 reject_statement ();
4991 st
= next_statement ();
4997 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4998 if (p
->state
== COMP_CONTAINS
)
5001 if (gfc_find_state (COMP_MODULE
) == true)
5006 gfc_error ("CONTAINS statement at %C is already in a contained "
5008 reject_statement ();
5009 st
= next_statement ();
5013 parse_contained (0);
5016 gfc_current_ns
->code
= gfc_state_stack
->head
;
5017 if (gfc_state_stack
->state
== COMP_PROGRAM
5018 || gfc_state_stack
->state
== COMP_MODULE
5019 || gfc_state_stack
->state
== COMP_SUBROUTINE
5020 || gfc_state_stack
->state
== COMP_FUNCTION
5021 || gfc_state_stack
->state
== COMP_BLOCK
)
5022 gfc_current_ns
->oacc_declare_clauses
5023 = gfc_state_stack
->ext
.oacc_declare_clauses
;
5027 /* Come here to complain about a global symbol already in use as
5031 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5036 where
= &gfc_current_locus
;
5046 case GSYM_SUBROUTINE
:
5047 name
= "SUBROUTINE";
5052 case GSYM_BLOCK_DATA
:
5053 name
= "BLOCK DATA";
5059 gfc_internal_error ("gfc_global_used(): Bad type");
5063 if (sym
->binding_label
)
5064 gfc_error ("Global binding name '%s' at %L is already being used as a %s "
5065 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5067 gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
5068 sym
->name
, where
, name
, &sym
->where
);
5072 /* Parse a block data program unit. */
5075 parse_block_data (void)
5078 static locus blank_locus
;
5079 static int blank_block
=0;
5082 gfc_current_ns
->proc_name
= gfc_new_block
;
5083 gfc_current_ns
->is_block_data
= 1;
5085 if (gfc_new_block
== NULL
)
5088 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5089 "prior BLOCK DATA at %L", &blank_locus
);
5093 blank_locus
= gfc_current_locus
;
5098 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5100 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5101 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5104 s
->type
= GSYM_BLOCK_DATA
;
5105 s
->where
= gfc_new_block
->declared_at
;
5110 st
= parse_spec (ST_NONE
);
5112 while (st
!= ST_END_BLOCK_DATA
)
5114 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5115 gfc_ascii_statement (st
));
5116 reject_statement ();
5117 st
= next_statement ();
5122 /* Parse a module subprogram. */
5131 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5132 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5133 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5136 s
->type
= GSYM_MODULE
;
5137 s
->where
= gfc_new_block
->declared_at
;
5141 st
= parse_spec (ST_NONE
);
5151 parse_contained (1);
5155 accept_statement (st
);
5159 gfc_error ("Unexpected %s statement in MODULE at %C",
5160 gfc_ascii_statement (st
));
5163 reject_statement ();
5164 st
= next_statement ();
5168 /* Make sure not to free the namespace twice on error. */
5170 s
->ns
= gfc_current_ns
;
5174 /* Add a procedure name to the global symbol table. */
5177 add_global_procedure (bool sub
)
5181 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5182 name is a global identifier. */
5183 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5185 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5188 || (s
->type
!= GSYM_UNKNOWN
5189 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5191 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5192 /* Silence follow-up errors. */
5193 gfc_new_block
->binding_label
= NULL
;
5197 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5198 s
->sym_name
= gfc_new_block
->name
;
5199 s
->where
= gfc_new_block
->declared_at
;
5201 s
->ns
= gfc_current_ns
;
5205 /* Don't add the symbol multiple times. */
5206 if (gfc_new_block
->binding_label
5207 && (!gfc_notification_std (GFC_STD_F2008
)
5208 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5210 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5213 || (s
->type
!= GSYM_UNKNOWN
5214 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5216 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5217 /* Silence follow-up errors. */
5218 gfc_new_block
->binding_label
= NULL
;
5222 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5223 s
->sym_name
= gfc_new_block
->name
;
5224 s
->binding_label
= gfc_new_block
->binding_label
;
5225 s
->where
= gfc_new_block
->declared_at
;
5227 s
->ns
= gfc_current_ns
;
5233 /* Add a program to the global symbol table. */
5236 add_global_program (void)
5240 if (gfc_new_block
== NULL
)
5242 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5244 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5245 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5248 s
->type
= GSYM_PROGRAM
;
5249 s
->where
= gfc_new_block
->declared_at
;
5251 s
->ns
= gfc_current_ns
;
5256 /* Resolve all the program units. */
5258 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5260 gfc_free_dt_list ();
5261 gfc_current_ns
= gfc_global_ns_list
;
5262 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5264 if (gfc_current_ns
->proc_name
5265 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5266 continue; /* Already resolved. */
5268 if (gfc_current_ns
->proc_name
)
5269 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5270 gfc_resolve (gfc_current_ns
);
5271 gfc_current_ns
->derived_types
= gfc_derived_types
;
5272 gfc_derived_types
= NULL
;
5278 clean_up_modules (gfc_gsymbol
*gsym
)
5283 clean_up_modules (gsym
->left
);
5284 clean_up_modules (gsym
->right
);
5286 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5289 gfc_current_ns
= gsym
->ns
;
5290 gfc_derived_types
= gfc_current_ns
->derived_types
;
5297 /* Translate all the program units. This could be in a different order
5298 to resolution if there are forward references in the file. */
5300 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5304 gfc_current_ns
= gfc_global_ns_list
;
5305 gfc_get_errors (NULL
, &errors
);
5307 /* We first translate all modules to make sure that later parts
5308 of the program can use the decl. Then we translate the nonmodules. */
5310 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5312 if (!gfc_current_ns
->proc_name
5313 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5316 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5317 gfc_derived_types
= gfc_current_ns
->derived_types
;
5318 gfc_generate_module_code (gfc_current_ns
);
5319 gfc_current_ns
->translated
= 1;
5322 gfc_current_ns
= gfc_global_ns_list
;
5323 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5325 if (gfc_current_ns
->proc_name
5326 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5329 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5330 gfc_derived_types
= gfc_current_ns
->derived_types
;
5331 gfc_generate_code (gfc_current_ns
);
5332 gfc_current_ns
->translated
= 1;
5335 /* Clean up all the namespaces after translation. */
5336 gfc_current_ns
= gfc_global_ns_list
;
5337 for (;gfc_current_ns
;)
5341 if (gfc_current_ns
->proc_name
5342 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5344 gfc_current_ns
= gfc_current_ns
->sibling
;
5348 ns
= gfc_current_ns
->sibling
;
5349 gfc_derived_types
= gfc_current_ns
->derived_types
;
5351 gfc_current_ns
= ns
;
5354 clean_up_modules (gfc_gsym_root
);
5358 /* Top level parser. */
5361 gfc_parse_file (void)
5363 int seen_program
, errors_before
, errors
;
5364 gfc_state_data top
, s
;
5367 gfc_namespace
*next
;
5369 gfc_start_source_files ();
5371 top
.state
= COMP_NONE
;
5373 top
.previous
= NULL
;
5374 top
.head
= top
.tail
= NULL
;
5375 top
.do_variable
= NULL
;
5377 gfc_state_stack
= &top
;
5379 gfc_clear_new_st ();
5381 gfc_statement_label
= NULL
;
5383 if (setjmp (eof_buf
))
5384 return false; /* Come here on unexpected EOF */
5386 /* Prepare the global namespace that will contain the
5388 gfc_global_ns_list
= next
= NULL
;
5393 /* Exit early for empty files. */
5399 st
= next_statement ();
5408 goto duplicate_main
;
5410 prog_locus
= gfc_current_locus
;
5412 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5413 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5414 accept_statement (st
);
5415 add_global_program ();
5416 parse_progunit (ST_NONE
);
5421 add_global_procedure (true);
5422 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5423 accept_statement (st
);
5424 parse_progunit (ST_NONE
);
5429 add_global_procedure (false);
5430 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5431 accept_statement (st
);
5432 parse_progunit (ST_NONE
);
5437 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5438 accept_statement (st
);
5439 parse_block_data ();
5443 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5444 accept_statement (st
);
5446 gfc_get_errors (NULL
, &errors_before
);
5450 /* Anything else starts a nameless main program block. */
5453 goto duplicate_main
;
5455 prog_locus
= gfc_current_locus
;
5457 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5458 main_program_symbol (gfc_current_ns
, "MAIN__");
5459 parse_progunit (st
);
5464 /* Handle the non-program units. */
5465 gfc_current_ns
->code
= s
.head
;
5467 gfc_resolve (gfc_current_ns
);
5469 /* Dump the parse tree if requested. */
5470 if (gfc_option
.dump_fortran_original
)
5471 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5473 gfc_get_errors (NULL
, &errors
);
5474 if (s
.state
== COMP_MODULE
)
5476 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5477 gfc_current_ns
->derived_types
= gfc_derived_types
;
5478 gfc_derived_types
= NULL
;
5484 gfc_generate_code (gfc_current_ns
);
5492 /* The main program and non-contained procedures are put
5493 in the global namespace list, so that they can be processed
5494 later and all their interfaces resolved. */
5495 gfc_current_ns
->code
= s
.head
;
5498 for (; next
->sibling
; next
= next
->sibling
)
5500 next
->sibling
= gfc_current_ns
;
5503 gfc_global_ns_list
= gfc_current_ns
;
5505 next
= gfc_current_ns
;
5512 /* Do the resolution. */
5513 resolve_all_program_units (gfc_global_ns_list
);
5515 /* Do the parse tree dump. */
5517 = gfc_option
.dump_fortran_original
? gfc_global_ns_list
: NULL
;
5519 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5520 if (!gfc_current_ns
->proc_name
5521 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5523 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5524 fputs ("------------------------------------------\n\n", stdout
);
5527 /* Do the translation. */
5528 translate_all_program_units (gfc_global_ns_list
);
5530 gfc_end_source_files ();
5534 /* If we see a duplicate main program, shut down. If the second
5535 instance is an implied main program, i.e. data decls or executable
5536 statements, we're in for lots of errors. */
5537 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
5538 reject_statement ();