| /* Main parser. |
| Copyright (C) 2000-2018 Free Software Foundation, Inc. |
| Contributed by Andy Vaught |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GCC; see the file COPYING3. If not see |
| <http://www.gnu.org/licenses/>. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "gfortran.h" |
| #include <setjmp.h> |
| #include "match.h" |
| #include "parse.h" |
| |
| /* Current statement label. Zero means no statement label. Because new_st |
| can get wiped during statement matching, we have to keep it separate. */ |
| |
| gfc_st_label *gfc_statement_label; |
| |
| static locus label_locus; |
| static jmp_buf eof_buf; |
| |
| gfc_state_data *gfc_state_stack; |
| static bool last_was_use_stmt = false; |
| |
| /* TODO: Re-order functions to kill these forward decls. */ |
| static void check_statement_label (gfc_statement); |
| static void undo_new_statement (void); |
| static void reject_statement (void); |
| |
| |
| /* A sort of half-matching function. We try to match the word on the |
| input with the passed string. If this succeeds, we call the |
| keyword-dependent matching function that will match the rest of the |
| statement. For single keywords, the matching subroutine is |
| gfc_match_eos(). */ |
| |
| static match |
| match_word (const char *str, match (*subr) (void), locus *old_locus) |
| { |
| match m; |
| |
| if (str != NULL) |
| { |
| m = gfc_match (str); |
| if (m != MATCH_YES) |
| return m; |
| } |
| |
| m = (*subr) (); |
| |
| if (m != MATCH_YES) |
| { |
| gfc_current_locus = *old_locus; |
| reject_statement (); |
| } |
| |
| return m; |
| } |
| |
| |
| /* Like match_word, but if str is matched, set a flag that it |
| was matched. */ |
| static match |
| match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus, |
| bool *simd_matched) |
| { |
| match m; |
| |
| if (str != NULL) |
| { |
| m = gfc_match (str); |
| if (m != MATCH_YES) |
| return m; |
| *simd_matched = true; |
| } |
| |
| m = (*subr) (); |
| |
| if (m != MATCH_YES) |
| { |
| gfc_current_locus = *old_locus; |
| reject_statement (); |
| } |
| |
| return m; |
| } |
| |
| |
| /* Load symbols from all USE statements encountered in this scoping unit. */ |
| |
| static void |
| use_modules (void) |
| { |
| gfc_error_buffer old_error; |
| |
| gfc_push_error (&old_error); |
| gfc_buffer_error (false); |
| gfc_use_modules (); |
| gfc_buffer_error (true); |
| gfc_pop_error (&old_error); |
| gfc_commit_symbols (); |
| gfc_warning_check (); |
| gfc_current_ns->old_equiv = gfc_current_ns->equiv; |
| gfc_current_ns->old_data = gfc_current_ns->data; |
| last_was_use_stmt = false; |
| } |
| |
| |
| /* Figure out what the next statement is, (mostly) regardless of |
| proper ordering. The do...while(0) is there to prevent if/else |
| ambiguity. */ |
| |
| #define match(keyword, subr, st) \ |
| do { \ |
| if (match_word (keyword, subr, &old_locus) == MATCH_YES) \ |
| return st; \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| |
| /* This is a specialist version of decode_statement that is used |
| for the specification statements in a function, whose |
| characteristics are deferred into the specification statements. |
| eg.: INTEGER (king = mykind) foo () |
| USE mymodule, ONLY mykind..... |
| The KIND parameter needs a return after USE or IMPORT, whereas |
| derived type declarations can occur anywhere, up the executable |
| block. ST_GET_FCN_CHARACTERISTICS is returned when we have run |
| out of the correct kind of specification statements. */ |
| static gfc_statement |
| decode_specification_statement (void) |
| { |
| gfc_statement st; |
| locus old_locus; |
| char c; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| return ST_NONE; |
| |
| old_locus = gfc_current_locus; |
| |
| if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) |
| { |
| last_was_use_stmt = true; |
| return ST_USE; |
| } |
| else |
| { |
| undo_new_statement (); |
| if (last_was_use_stmt) |
| use_modules (); |
| } |
| |
| match ("import", gfc_match_import, ST_IMPORT); |
| |
| if (gfc_current_block ()->result->ts.type != BT_DERIVED) |
| goto end_of_block; |
| |
| match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); |
| match (NULL, gfc_match_data_decl, ST_DATA_DECL); |
| match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); |
| |
| /* General statement matching: Instead of testing every possible |
| statement, we eliminate most possibilities by peeking at the |
| first character. */ |
| |
| c = gfc_peek_ascii_char (); |
| |
| switch (c) |
| { |
| case 'a': |
| match ("abstract% interface", gfc_match_abstract_interface, |
| ST_INTERFACE); |
| match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); |
| match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); |
| match ("automatic", gfc_match_automatic, ST_ATTR_DECL); |
| break; |
| |
| case 'b': |
| match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); |
| break; |
| |
| case 'c': |
| match ("codimension", gfc_match_codimension, ST_ATTR_DECL); |
| match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); |
| break; |
| |
| case 'd': |
| match ("data", gfc_match_data, ST_DATA); |
| match ("dimension", gfc_match_dimension, ST_ATTR_DECL); |
| break; |
| |
| case 'e': |
| match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); |
| match ("entry% ", gfc_match_entry, ST_ENTRY); |
| match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); |
| match ("external", gfc_match_external, ST_ATTR_DECL); |
| break; |
| |
| case 'f': |
| match ("format", gfc_match_format, ST_FORMAT); |
| break; |
| |
| case 'g': |
| break; |
| |
| case 'i': |
| match ("implicit", gfc_match_implicit, ST_IMPLICIT); |
| match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); |
| match ("interface", gfc_match_interface, ST_INTERFACE); |
| match ("intent", gfc_match_intent, ST_ATTR_DECL); |
| match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); |
| break; |
| |
| case 'm': |
| break; |
| |
| case 'n': |
| match ("namelist", gfc_match_namelist, ST_NAMELIST); |
| break; |
| |
| case 'o': |
| match ("optional", gfc_match_optional, ST_ATTR_DECL); |
| break; |
| |
| case 'p': |
| match ("parameter", gfc_match_parameter, ST_PARAMETER); |
| match ("pointer", gfc_match_pointer, ST_ATTR_DECL); |
| if (gfc_match_private (&st) == MATCH_YES) |
| return st; |
| match ("procedure", gfc_match_procedure, ST_PROCEDURE); |
| if (gfc_match_public (&st) == MATCH_YES) |
| return st; |
| match ("protected", gfc_match_protected, ST_ATTR_DECL); |
| break; |
| |
| case 'r': |
| break; |
| |
| case 's': |
| match ("save", gfc_match_save, ST_ATTR_DECL); |
| match ("static", gfc_match_static, ST_ATTR_DECL); |
| match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); |
| break; |
| |
| case 't': |
| match ("target", gfc_match_target, ST_ATTR_DECL); |
| match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); |
| break; |
| |
| case 'u': |
| break; |
| |
| case 'v': |
| match ("value", gfc_match_value, ST_ATTR_DECL); |
| match ("volatile", gfc_match_volatile, ST_ATTR_DECL); |
| break; |
| |
| case 'w': |
| break; |
| } |
| |
| /* This is not a specification statement. See if any of the matchers |
| has stored an error message of some sort. */ |
| |
| end_of_block: |
| gfc_clear_error (); |
| gfc_buffer_error (false); |
| gfc_current_locus = old_locus; |
| |
| return ST_GET_FCN_CHARACTERISTICS; |
| } |
| |
| static bool in_specification_block; |
| |
| /* This is the primary 'decode_statement'. */ |
| static gfc_statement |
| decode_statement (void) |
| { |
| gfc_statement st; |
| locus old_locus; |
| match m = MATCH_NO; |
| char c; |
| |
| gfc_enforce_clean_symbol_state (); |
| |
| gfc_clear_error (); /* Clear any pending errors. */ |
| gfc_clear_warning (); /* Clear any pending warnings. */ |
| |
| gfc_matching_function = false; |
| |
| if (gfc_match_eos () == MATCH_YES) |
| return ST_NONE; |
| |
| if (gfc_current_state () == COMP_FUNCTION |
| && gfc_current_block ()->result->ts.kind == -1) |
| return decode_specification_statement (); |
| |
| old_locus = gfc_current_locus; |
| |
| c = gfc_peek_ascii_char (); |
| |
| if (c == 'u') |
| { |
| if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES) |
| { |
| last_was_use_stmt = true; |
| return ST_USE; |
| } |
| else |
| undo_new_statement (); |
| } |
| |
| if (last_was_use_stmt) |
| use_modules (); |
| |
| /* Try matching a data declaration or function declaration. The |
| input "REALFUNCTIONA(N)" can mean several things in different |
| contexts, so it (and its relatives) get special treatment. */ |
| |
| if (gfc_current_state () == COMP_NONE |
| || gfc_current_state () == COMP_INTERFACE |
| || gfc_current_state () == COMP_CONTAINS) |
| { |
| gfc_matching_function = true; |
| m = gfc_match_function_decl (); |
| if (m == MATCH_YES) |
| return ST_FUNCTION; |
| else if (m == MATCH_ERROR) |
| reject_statement (); |
| else |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| } |
| gfc_matching_function = false; |
| |
| /* Legacy parameter statements are ambiguous with assignments so try parameter |
| first. */ |
| match ("parameter", gfc_match_parameter, ST_PARAMETER); |
| |
| /* Match statements whose error messages are meant to be overwritten |
| by something better. */ |
| |
| match (NULL, gfc_match_assignment, ST_ASSIGNMENT); |
| match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); |
| |
| if (in_specification_block) |
| { |
| m = match_word (NULL, gfc_match_st_function, &old_locus); |
| if (m == MATCH_YES) |
| return ST_STATEMENT_FUNCTION; |
| } |
| |
| if (!(in_specification_block && m == MATCH_ERROR)) |
| { |
| match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT); |
| } |
| |
| match (NULL, gfc_match_data_decl, ST_DATA_DECL); |
| match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); |
| |
| /* Try to match a subroutine statement, which has the same optional |
| prefixes that functions can have. */ |
| |
| if (gfc_match_subroutine () == MATCH_YES) |
| return ST_SUBROUTINE; |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| if (gfc_match_submod_proc () == MATCH_YES) |
| { |
| if (gfc_new_block->attr.subroutine) |
| return ST_SUBROUTINE; |
| else if (gfc_new_block->attr.function) |
| return ST_FUNCTION; |
| } |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE |
| statements, which might begin with a block label. The match functions for |
| these statements are unusual in that their keyword is not seen before |
| the matcher is called. */ |
| |
| if (gfc_match_if (&st) == MATCH_YES) |
| return st; |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| if (gfc_match_where (&st) == MATCH_YES) |
| return st; |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| if (gfc_match_forall (&st) == MATCH_YES) |
| return st; |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| /* Try to match TYPE as an alias for PRINT. */ |
| if (gfc_match_type (&st) == MATCH_YES) |
| return st; |
| gfc_undo_symbols (); |
| gfc_current_locus = old_locus; |
| |
| match (NULL, gfc_match_do, ST_DO); |
| match (NULL, gfc_match_block, ST_BLOCK); |
| match (NULL, gfc_match_associate, ST_ASSOCIATE); |
| match (NULL, gfc_match_critical, ST_CRITICAL); |
| match (NULL, gfc_match_select, ST_SELECT_CASE); |
| match (NULL, gfc_match_select_type, ST_SELECT_TYPE); |
| |
| /* General statement matching: Instead of testing every possible |
| statement, we eliminate most possibilities by peeking at the |
| first character. */ |
| |
| switch (c) |
| { |
| case 'a': |
| match ("abstract% interface", gfc_match_abstract_interface, |
| ST_INTERFACE); |
| match ("allocate", gfc_match_allocate, ST_ALLOCATE); |
| match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); |
| match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); |
| match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL); |
| match ("automatic", gfc_match_automatic, ST_ATTR_DECL); |
| break; |
| |
| case 'b': |
| match ("backspace", gfc_match_backspace, ST_BACKSPACE); |
| match ("block data", gfc_match_block_data, ST_BLOCK_DATA); |
| match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); |
| break; |
| |
| case 'c': |
| match ("call", gfc_match_call, ST_CALL); |
| match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); |
| match ("close", gfc_match_close, ST_CLOSE); |
| match ("continue", gfc_match_continue, ST_CONTINUE); |
| match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); |
| match ("cycle", gfc_match_cycle, ST_CYCLE); |
| match ("case", gfc_match_case, ST_CASE); |
| match ("common", gfc_match_common, ST_COMMON); |
| match ("contains", gfc_match_eos, ST_CONTAINS); |
| match ("class", gfc_match_class_is, ST_CLASS_IS); |
| match ("codimension", gfc_match_codimension, ST_ATTR_DECL); |
| break; |
| |
| case 'd': |
| match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); |
| match ("data", gfc_match_data, ST_DATA); |
| match ("dimension", gfc_match_dimension, ST_ATTR_DECL); |
| break; |
| |
| case 'e': |
| match ("end file", gfc_match_endfile, ST_END_FILE); |
| match ("end team", gfc_match_end_team, ST_END_TEAM); |
| match ("exit", gfc_match_exit, ST_EXIT); |
| match ("else", gfc_match_else, ST_ELSE); |
| match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); |
| match ("else if", gfc_match_elseif, ST_ELSEIF); |
| match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); |
| match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); |
| |
| if (gfc_match_end (&st) == MATCH_YES) |
| return st; |
| |
| match ("entry% ", gfc_match_entry, ST_ENTRY); |
| match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); |
| match ("external", gfc_match_external, ST_ATTR_DECL); |
| match ("event post", gfc_match_event_post, ST_EVENT_POST); |
| match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT); |
| break; |
| |
| case 'f': |
| match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); |
| match ("final", gfc_match_final_decl, ST_FINAL); |
| match ("flush", gfc_match_flush, ST_FLUSH); |
| match ("form team", gfc_match_form_team, ST_FORM_TEAM); |
| match ("format", gfc_match_format, ST_FORMAT); |
| break; |
| |
| case 'g': |
| match ("generic", gfc_match_generic, ST_GENERIC); |
| match ("go to", gfc_match_goto, ST_GOTO); |
| break; |
| |
| case 'i': |
| match ("inquire", gfc_match_inquire, ST_INQUIRE); |
| match ("implicit", gfc_match_implicit, ST_IMPLICIT); |
| match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); |
| match ("import", gfc_match_import, ST_IMPORT); |
| match ("interface", gfc_match_interface, ST_INTERFACE); |
| match ("intent", gfc_match_intent, ST_ATTR_DECL); |
| match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); |
| break; |
| |
| case 'l': |
| match ("lock", gfc_match_lock, ST_LOCK); |
| break; |
| |
| case 'm': |
| match ("map", gfc_match_map, ST_MAP); |
| match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); |
| match ("module", gfc_match_module, ST_MODULE); |
| break; |
| |
| case 'n': |
| match ("nullify", gfc_match_nullify, ST_NULLIFY); |
| match ("namelist", gfc_match_namelist, ST_NAMELIST); |
| break; |
| |
| case 'o': |
| match ("open", gfc_match_open, ST_OPEN); |
| match ("optional", gfc_match_optional, ST_ATTR_DECL); |
| break; |
| |
| case 'p': |
| match ("print", gfc_match_print, ST_WRITE); |
| match ("pause", gfc_match_pause, ST_PAUSE); |
| match ("pointer", gfc_match_pointer, ST_ATTR_DECL); |
| if (gfc_match_private (&st) == MATCH_YES) |
| return st; |
| match ("procedure", gfc_match_procedure, ST_PROCEDURE); |
| match ("program", gfc_match_program, ST_PROGRAM); |
| if (gfc_match_public (&st) == MATCH_YES) |
| return st; |
| match ("protected", gfc_match_protected, ST_ATTR_DECL); |
| break; |
| |
| case 'r': |
| match ("read", gfc_match_read, ST_READ); |
| match ("return", gfc_match_return, ST_RETURN); |
| match ("rewind", gfc_match_rewind, ST_REWIND); |
| break; |
| |
| case 's': |
| match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); |
| match ("sequence", gfc_match_eos, ST_SEQUENCE); |
| match ("stop", gfc_match_stop, ST_STOP); |
| match ("save", gfc_match_save, ST_ATTR_DECL); |
| match ("static", gfc_match_static, ST_ATTR_DECL); |
| match ("submodule", gfc_match_submodule, ST_SUBMODULE); |
| match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); |
| match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); |
| match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); |
| match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); |
| break; |
| |
| case 't': |
| match ("target", gfc_match_target, ST_ATTR_DECL); |
| match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); |
| match ("type is", gfc_match_type_is, ST_TYPE_IS); |
| break; |
| |
| case 'u': |
| match ("union", gfc_match_union, ST_UNION); |
| match ("unlock", gfc_match_unlock, ST_UNLOCK); |
| break; |
| |
| case 'v': |
| match ("value", gfc_match_value, ST_ATTR_DECL); |
| match ("volatile", gfc_match_volatile, ST_ATTR_DECL); |
| break; |
| |
| case 'w': |
| match ("wait", gfc_match_wait, ST_WAIT); |
| match ("write", gfc_match_write, ST_WRITE); |
| break; |
| } |
| |
| /* All else has failed, so give up. See if any of the matchers has |
| stored an error message of some sort. */ |
| |
| if (!gfc_error_check ()) |
| gfc_error_now ("Unclassifiable statement at %C"); |
| |
| reject_statement (); |
| |
| gfc_error_recovery (); |
| |
| return ST_NONE; |
| } |
| |
| /* Like match and if spec_only, goto do_spec_only without actually |
| matching. */ |
| #define matcha(keyword, subr, st) \ |
| do { \ |
| if (spec_only && gfc_match (keyword) == MATCH_YES) \ |
| goto do_spec_only; \ |
| else if (match_word (keyword, subr, &old_locus) \ |
| == MATCH_YES) \ |
| return st; \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| static gfc_statement |
| decode_oacc_directive (void) |
| { |
| locus old_locus; |
| char c; |
| bool spec_only = false; |
| |
| gfc_enforce_clean_symbol_state (); |
| |
| gfc_clear_error (); /* Clear any pending errors. */ |
| gfc_clear_warning (); /* Clear any pending warnings. */ |
| |
| gfc_matching_function = false; |
| |
| if (gfc_pure (NULL)) |
| { |
| gfc_error_now ("OpenACC directives at %C may not appear in PURE " |
| "procedures"); |
| gfc_error_recovery (); |
| return ST_NONE; |
| } |
| |
| if (gfc_current_state () == COMP_FUNCTION |
| && gfc_current_block ()->result->ts.kind == -1) |
| spec_only = true; |
| |
| gfc_unset_implicit_pure (NULL); |
| |
| old_locus = gfc_current_locus; |
| |
| /* General OpenACC directive matching: Instead of testing every possible |
| statement, we eliminate most possibilities by peeking at the |
| first character. */ |
| |
| c = gfc_peek_ascii_char (); |
| |
| switch (c) |
| { |
| case 'a': |
| matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); |
| break; |
| case 'c': |
| matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); |
| break; |
| case 'd': |
| matcha ("data", gfc_match_oacc_data, ST_OACC_DATA); |
| match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); |
| break; |
| case 'e': |
| matcha ("end atomic", gfc_match_omp_eos, ST_OACC_END_ATOMIC); |
| matcha ("end data", gfc_match_omp_eos, ST_OACC_END_DATA); |
| matcha ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA); |
| matcha ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LOOP); |
| matcha ("end kernels", gfc_match_omp_eos, ST_OACC_END_KERNELS); |
| matcha ("end loop", gfc_match_omp_eos, ST_OACC_END_LOOP); |
| matcha ("end parallel loop", gfc_match_omp_eos, |
| ST_OACC_END_PARALLEL_LOOP); |
| matcha ("end parallel", gfc_match_omp_eos, ST_OACC_END_PARALLEL); |
| matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA); |
| matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA); |
| break; |
| case 'h': |
| matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); |
| break; |
| case 'p': |
| matcha ("parallel loop", gfc_match_oacc_parallel_loop, |
| ST_OACC_PARALLEL_LOOP); |
| matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); |
| break; |
| case 'k': |
| matcha ("kernels loop", gfc_match_oacc_kernels_loop, |
| ST_OACC_KERNELS_LOOP); |
| matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); |
| break; |
| case 'l': |
| matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); |
| break; |
| case 'r': |
| match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); |
| break; |
| case 'u': |
| matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE); |
| break; |
| case 'w': |
| matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); |
| break; |
| } |
| |
| /* Directive not found or stored an error message. |
| Check and give up. */ |
| |
| if (gfc_error_check () == 0) |
| gfc_error_now ("Unclassifiable OpenACC directive at %C"); |
| |
| reject_statement (); |
| |
| gfc_error_recovery (); |
| |
| return ST_NONE; |
| |
| do_spec_only: |
| reject_statement (); |
| gfc_clear_error (); |
| gfc_buffer_error (false); |
| gfc_current_locus = old_locus; |
| return ST_GET_FCN_CHARACTERISTICS; |
| } |
| |
| /* Like match, but set a flag simd_matched if keyword matched |
| and if spec_only, goto do_spec_only without actually matching. */ |
| #define matchs(keyword, subr, st) \ |
| do { \ |
| if (spec_only && gfc_match (keyword) == MATCH_YES) \ |
| goto do_spec_only; \ |
| if (match_word_omp_simd (keyword, subr, &old_locus, \ |
| &simd_matched) == MATCH_YES) \ |
| { \ |
| ret = st; \ |
| goto finish; \ |
| } \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| /* Like match, but don't match anything if not -fopenmp |
| and if spec_only, goto do_spec_only without actually matching. */ |
| #define matcho(keyword, subr, st) \ |
| do { \ |
| if (!flag_openmp) \ |
| ; \ |
| else if (spec_only && gfc_match (keyword) == MATCH_YES) \ |
| goto do_spec_only; \ |
| else if (match_word (keyword, subr, &old_locus) \ |
| == MATCH_YES) \ |
| { \ |
| ret = st; \ |
| goto finish; \ |
| } \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| /* Like match, but set a flag simd_matched if keyword matched. */ |
| #define matchds(keyword, subr, st) \ |
| do { \ |
| if (match_word_omp_simd (keyword, subr, &old_locus, \ |
| &simd_matched) == MATCH_YES) \ |
| { \ |
| ret = st; \ |
| goto finish; \ |
| } \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| /* Like match, but don't match anything if not -fopenmp. */ |
| #define matchdo(keyword, subr, st) \ |
| do { \ |
| if (!flag_openmp) \ |
| ; \ |
| else if (match_word (keyword, subr, &old_locus) \ |
| == MATCH_YES) \ |
| { \ |
| ret = st; \ |
| goto finish; \ |
| } \ |
| else \ |
| undo_new_statement (); \ |
| } while (0) |
| |
| static gfc_statement |
| decode_omp_directive (void) |
| { |
| locus old_locus; |
| char c; |
| bool simd_matched = false; |
| bool spec_only = false; |
| gfc_statement ret = ST_NONE; |
| bool pure_ok = true; |
| |
| gfc_enforce_clean_symbol_state (); |
| |
| gfc_clear_error (); /* Clear any pending errors. */ |
| gfc_clear_warning (); /* Clear any pending warnings. */ |
| |
| gfc_matching_function = false; |
| |
| if (gfc_current_state () == COMP_FUNCTION |
| && gfc_current_block ()->result->ts.kind == -1) |
| spec_only = true; |
| |
| old_locus = gfc_current_locus; |
| |
| /* General OpenMP directive matching: Instead of testing every possible |
| statement, we eliminate most possibilities by peeking at the |
| first character. */ |
| |
| c = gfc_peek_ascii_char (); |
| |
| /* match is for directives that should be recognized only if |
| -fopenmp, matchs for directives that should be recognized |
| if either -fopenmp or -fopenmp-simd. |
| Handle only the directives allowed in PURE/ELEMENTAL procedures |
| first (those also shall not turn off implicit pure). */ |
| switch (c) |
| { |
| case 'd': |
| matchds ("declare simd", gfc_match_omp_declare_simd, |
| ST_OMP_DECLARE_SIMD); |
| matchdo ("declare target", gfc_match_omp_declare_target, |
| ST_OMP_DECLARE_TARGET); |
| break; |
| case 's': |
| matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); |
| break; |
| } |
| |
| pure_ok = false; |
| if (flag_openmp && gfc_pure (NULL)) |
| { |
| gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " |
| "at %C may not appear in PURE or ELEMENTAL procedures"); |
| gfc_error_recovery (); |
| return ST_NONE; |
| } |
| |
| /* match is for directives that should be recognized only if |
| -fopenmp, matchs for directives that should be recognized |
| if either -fopenmp or -fopenmp-simd. */ |
| switch (c) |
| { |
| case 'a': |
| matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); |
| break; |
| case 'b': |
| matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); |
| break; |
| case 'c': |
| matcho ("cancellation% point", gfc_match_omp_cancellation_point, |
| ST_OMP_CANCELLATION_POINT); |
| matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL); |
| matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); |
| break; |
| case 'd': |
| matchds ("declare reduction", gfc_match_omp_declare_reduction, |
| ST_OMP_DECLARE_REDUCTION); |
| matchs ("distribute parallel do simd", |
| gfc_match_omp_distribute_parallel_do_simd, |
| ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do, |
| ST_OMP_DISTRIBUTE_PARALLEL_DO); |
| matchs ("distribute simd", gfc_match_omp_distribute_simd, |
| ST_OMP_DISTRIBUTE_SIMD); |
| matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE); |
| matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD); |
| matcho ("do", gfc_match_omp_do, ST_OMP_DO); |
| break; |
| case 'e': |
| matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC); |
| matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); |
| matchs ("end distribute parallel do simd", gfc_match_omp_eos, |
| ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("end distribute parallel do", gfc_match_omp_eos, |
| ST_OMP_END_DISTRIBUTE_PARALLEL_DO); |
| matchs ("end distribute simd", gfc_match_omp_eos, |
| ST_OMP_END_DISTRIBUTE_SIMD); |
| matcho ("end distribute", gfc_match_omp_eos, ST_OMP_END_DISTRIBUTE); |
| matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); |
| matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); |
| matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD); |
| matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER); |
| matchs ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED); |
| matchs ("end parallel do simd", gfc_match_omp_eos, |
| ST_OMP_END_PARALLEL_DO_SIMD); |
| matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO); |
| matcho ("end parallel sections", gfc_match_omp_eos, |
| ST_OMP_END_PARALLEL_SECTIONS); |
| matcho ("end parallel workshare", gfc_match_omp_eos, |
| ST_OMP_END_PARALLEL_WORKSHARE); |
| matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL); |
| matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); |
| matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); |
| matcho ("end target data", gfc_match_omp_eos, ST_OMP_END_TARGET_DATA); |
| matchs ("end target parallel do simd", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_PARALLEL_DO_SIMD); |
| matcho ("end target parallel do", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_PARALLEL_DO); |
| matcho ("end target parallel", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_PARALLEL); |
| matchs ("end target simd", gfc_match_omp_eos, ST_OMP_END_TARGET_SIMD); |
| matchs ("end target teams distribute parallel do simd", |
| gfc_match_omp_eos, |
| ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("end target teams distribute parallel do", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); |
| matchs ("end target teams distribute simd", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD); |
| matcho ("end target teams distribute", gfc_match_omp_eos, |
| ST_OMP_END_TARGET_TEAMS_DISTRIBUTE); |
| matcho ("end target teams", gfc_match_omp_eos, ST_OMP_END_TARGET_TEAMS); |
| matcho ("end target", gfc_match_omp_eos, ST_OMP_END_TARGET); |
| matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP); |
| matchs ("end taskloop simd", gfc_match_omp_eos, |
| ST_OMP_END_TASKLOOP_SIMD); |
| matcho ("end taskloop", gfc_match_omp_eos, ST_OMP_END_TASKLOOP); |
| matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK); |
| matchs ("end teams distribute parallel do simd", gfc_match_omp_eos, |
| ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("end teams distribute parallel do", gfc_match_omp_eos, |
| ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO); |
| matchs ("end teams distribute simd", gfc_match_omp_eos, |
| ST_OMP_END_TEAMS_DISTRIBUTE_SIMD); |
| matcho ("end teams distribute", gfc_match_omp_eos, |
| ST_OMP_END_TEAMS_DISTRIBUTE); |
| matcho ("end teams", gfc_match_omp_eos, ST_OMP_END_TEAMS); |
| matcho ("end workshare", gfc_match_omp_end_nowait, |
| ST_OMP_END_WORKSHARE); |
| break; |
| case 'f': |
| matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); |
| break; |
| case 'm': |
| matcho ("master", gfc_match_omp_master, ST_OMP_MASTER); |
| break; |
| case 'o': |
| if (gfc_match ("ordered depend (") == MATCH_YES) |
| { |
| gfc_current_locus = old_locus; |
| if (!flag_openmp) |
| break; |
| matcho ("ordered", gfc_match_omp_ordered_depend, |
| ST_OMP_ORDERED_DEPEND); |
| } |
| else |
| matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); |
| break; |
| case 'p': |
| matchs ("parallel do simd", gfc_match_omp_parallel_do_simd, |
| ST_OMP_PARALLEL_DO_SIMD); |
| matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); |
| matcho ("parallel sections", gfc_match_omp_parallel_sections, |
| ST_OMP_PARALLEL_SECTIONS); |
| matcho ("parallel workshare", gfc_match_omp_parallel_workshare, |
| ST_OMP_PARALLEL_WORKSHARE); |
| matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); |
| break; |
| case 's': |
| matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); |
| matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION); |
| matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE); |
| break; |
| case 't': |
| matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA); |
| matcho ("target enter data", gfc_match_omp_target_enter_data, |
| ST_OMP_TARGET_ENTER_DATA); |
| matcho ("target exit data", gfc_match_omp_target_exit_data, |
| ST_OMP_TARGET_EXIT_DATA); |
| matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd, |
| ST_OMP_TARGET_PARALLEL_DO_SIMD); |
| matcho ("target parallel do", gfc_match_omp_target_parallel_do, |
| ST_OMP_TARGET_PARALLEL_DO); |
| matcho ("target parallel", gfc_match_omp_target_parallel, |
| ST_OMP_TARGET_PARALLEL); |
| matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD); |
| matchs ("target teams distribute parallel do simd", |
| gfc_match_omp_target_teams_distribute_parallel_do_simd, |
| ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("target teams distribute parallel do", |
| gfc_match_omp_target_teams_distribute_parallel_do, |
| ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO); |
| matchs ("target teams distribute simd", |
| gfc_match_omp_target_teams_distribute_simd, |
| ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD); |
| matcho ("target teams distribute", gfc_match_omp_target_teams_distribute, |
| ST_OMP_TARGET_TEAMS_DISTRIBUTE); |
| matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS); |
| matcho ("target update", gfc_match_omp_target_update, |
| ST_OMP_TARGET_UPDATE); |
| matcho ("target", gfc_match_omp_target, ST_OMP_TARGET); |
| matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP); |
| matchs ("taskloop simd", gfc_match_omp_taskloop_simd, |
| ST_OMP_TASKLOOP_SIMD); |
| matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP); |
| matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT); |
| matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD); |
| matcho ("task", gfc_match_omp_task, ST_OMP_TASK); |
| matchs ("teams distribute parallel do simd", |
| gfc_match_omp_teams_distribute_parallel_do_simd, |
| ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD); |
| matcho ("teams distribute parallel do", |
| gfc_match_omp_teams_distribute_parallel_do, |
| ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO); |
| matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd, |
| ST_OMP_TEAMS_DISTRIBUTE_SIMD); |
| matcho ("teams distribute", gfc_match_omp_teams_distribute, |
| ST_OMP_TEAMS_DISTRIBUTE); |
| matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); |
| matchdo ("threadprivate", gfc_match_omp_threadprivate, |
| ST_OMP_THREADPRIVATE); |
| break; |
| case 'w': |
| matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); |
| break; |
| } |
| |
| /* All else has failed, so give up. See if any of the matchers has |
| stored an error message of some sort. Don't error out if |
| not -fopenmp and simd_matched is false, i.e. if a directive other |
| than one marked with match has been seen. */ |
| |
| if (flag_openmp || simd_matched) |
| { |
| if (!gfc_error_check ()) |
| gfc_error_now ("Unclassifiable OpenMP directive at %C"); |
| } |
| |
| reject_statement (); |
| |
| gfc_error_recovery (); |
| |
| return ST_NONE; |
| |
| finish: |
| if (!pure_ok) |
| { |
| gfc_unset_implicit_pure (NULL); |
| |
| if (!flag_openmp && gfc_pure (NULL)) |
| { |
| gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " |
| "at %C may not appear in PURE or ELEMENTAL " |
| "procedures"); |
| reject_statement (); |
| gfc_error_recovery (); |
| return ST_NONE; |
| } |
| } |
| return ret; |
| |
| do_spec_only: |
| reject_statement (); |
| gfc_clear_error (); |
| gfc_buffer_error (false); |
| gfc_current_locus = old_locus; |
| return ST_GET_FCN_CHARACTERISTICS; |
| } |
| |
| static gfc_statement |
| decode_gcc_attribute (void) |
| { |
| locus old_locus; |
| |
| gfc_enforce_clean_symbol_state (); |
| |
| gfc_clear_error (); /* Clear any pending errors. */ |
| gfc_clear_warning (); /* Clear any pending warnings. */ |
| old_locus = gfc_current_locus; |
| |
| match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL); |
| match ("unroll", gfc_match_gcc_unroll, ST_NONE); |
| |
| /* All else has failed, so give up. See if any of the matchers has |
| stored an error message of some sort. */ |
| |
| if (!gfc_error_check ()) |
| gfc_error_now ("Unclassifiable GCC directive at %C"); |
| |
| reject_statement (); |
| |
| gfc_error_recovery (); |
| |
| return ST_NONE; |
| } |
| |
| #undef match |
| |
| /* Assert next length characters to be equal to token in free form. */ |
| |
| static void |
| verify_token_free (const char* token, int length, bool last_was_use_stmt) |
| { |
| int i; |
| char c; |
| |
| c = gfc_next_ascii_char (); |
| for (i = 0; i < length; i++, c = gfc_next_ascii_char ()) |
| gcc_assert (c == token[i]); |
| |
| gcc_assert (gfc_is_whitespace(c)); |
| gfc_gobble_whitespace (); |
| if (last_was_use_stmt) |
| use_modules (); |
| } |
| |
| /* Get the next statement in free form source. */ |
| |
| static gfc_statement |
| next_free (void) |
| { |
| match m; |
| int i, cnt, at_bol; |
| char c; |
| |
| at_bol = gfc_at_bol (); |
| gfc_gobble_whitespace (); |
| |
| c = gfc_peek_ascii_char (); |
| |
| if (ISDIGIT (c)) |
| { |
| char d; |
| |
| /* Found a statement label? */ |
| m = gfc_match_st_label (&gfc_statement_label); |
| |
| d = gfc_peek_ascii_char (); |
| if (m != MATCH_YES || !gfc_is_whitespace (d)) |
| { |
| gfc_match_small_literal_int (&i, &cnt); |
| |
| if (cnt > 5) |
| gfc_error_now ("Too many digits in statement label at %C"); |
| |
| if (i == 0) |
| gfc_error_now ("Zero is not a valid statement label at %C"); |
| |
| do |
| c = gfc_next_ascii_char (); |
| while (ISDIGIT(c)); |
| |
| if (!gfc_is_whitespace (c)) |
| gfc_error_now ("Non-numeric character in statement label at %C"); |
| |
| return ST_NONE; |
| } |
| else |
| { |
| label_locus = gfc_current_locus; |
| |
| gfc_gobble_whitespace (); |
| |
| if (at_bol && gfc_peek_ascii_char () == ';') |
| { |
| gfc_error_now ("Semicolon at %C needs to be preceded by " |
| "statement"); |
| gfc_next_ascii_char (); /* Eat up the semicolon. */ |
| return ST_NONE; |
| } |
| |
| if (gfc_match_eos () == MATCH_YES) |
| gfc_error_now ("Statement label without statement at %L", |
| &label_locus); |
| } |
| } |
| else if (c == '!') |
| { |
| /* Comments have already been skipped by the time we get here, |
| except for GCC attributes and OpenMP/OpenACC directives. */ |
| |
| gfc_next_ascii_char (); /* Eat up the exclamation sign. */ |
| c = gfc_peek_ascii_char (); |
| |
| if (c == 'g') |
| { |
| int i; |
| |
| c = gfc_next_ascii_char (); |
| for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) |
| gcc_assert (c == "gcc$"[i]); |
| |
| gfc_gobble_whitespace (); |
| return decode_gcc_attribute (); |
| |
| } |
| else if (c == '$') |
| { |
| /* Since both OpenMP and OpenACC directives starts with |
| !$ character sequence, we must check all flags combinations */ |
| if ((flag_openmp || flag_openmp_simd) |
| && !flag_openacc) |
| { |
| verify_token_free ("$omp", 4, last_was_use_stmt); |
| return decode_omp_directive (); |
| } |
| else if ((flag_openmp || flag_openmp_simd) |
| && flag_openacc) |
| { |
| gfc_next_ascii_char (); /* Eat up dollar character */ |
| c = gfc_peek_ascii_char (); |
| |
| if (c == 'o') |
| { |
| verify_token_free ("omp", 3, last_was_use_stmt); |
| return decode_omp_directive (); |
| } |
| else if (c == 'a') |
| { |
| verify_token_free ("acc", 3, last_was_use_stmt); |
| return decode_oacc_directive (); |
| } |
| } |
| else if (flag_openacc) |
| { |
| verify_token_free ("$acc", 4, last_was_use_stmt); |
| return decode_oacc_directive (); |
| } |
| } |
| gcc_unreachable (); |
| } |
| |
| if (at_bol && c == ';') |
| { |
| if (!(gfc_option.allow_std & GFC_STD_F2008)) |
| gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " |
| "statement"); |
| gfc_next_ascii_char (); /* Eat up the semicolon. */ |
| return ST_NONE; |
| } |
| |
| return decode_statement (); |
| } |
| |
| /* Assert next length characters to be equal to token in fixed form. */ |
| |
| static bool |
| verify_token_fixed (const char *token, int length, bool last_was_use_stmt) |
| { |
| int i; |
| char c = gfc_next_char_literal (NONSTRING); |
| |
| for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING)) |
| gcc_assert ((char) gfc_wide_tolower (c) == token[i]); |
| |
| if (c != ' ' && c != '0') |
| { |
| gfc_buffer_error (false); |
| gfc_error ("Bad continuation line at %C"); |
| return false; |
| } |
| if (last_was_use_stmt) |
| use_modules (); |
| |
| return true; |
| } |
| |
| /* Get the next statement in fixed-form source. */ |
| |
| static gfc_statement |
| next_fixed (void) |
| { |
| int label, digit_flag, i; |
| locus loc; |
| gfc_char_t c; |
| |
| if (!gfc_at_bol ()) |
| return decode_statement (); |
| |
| /* Skip past the current label field, parsing a statement label if |
| one is there. This is a weird number parser, since the number is |
| contained within five columns and can have any kind of embedded |
| spaces. We also check for characters that make the rest of the |
| line a comment. */ |
| |
| label = 0; |
| digit_flag = 0; |
| |
| for (i = 0; i < 5; i++) |
| { |
| c = gfc_next_char_literal (NONSTRING); |
| |
| switch (c) |
| { |
| case ' ': |
| break; |
| |
| case '0': |
| case '1': |
| case '2': |
| case '3': |
| case '4': |
| case '5': |
| case '6': |
| case '7': |
| case '8': |
| case '9': |
| label = label * 10 + ((unsigned char) c - '0'); |
| label_locus = gfc_current_locus; |
| digit_flag = 1; |
| break; |
| |
| /* Comments have already been skipped by the time we get |
| here, except for GCC attributes and OpenMP directives. */ |
| |
| case '*': |
| c = gfc_next_char_literal (NONSTRING); |
| |
| if (TOLOWER (c) == 'g') |
| { |
| for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING)) |
| gcc_assert (TOLOWER (c) == "gcc$"[i]); |
| |
| return decode_gcc_attribute (); |
| } |
| else if (c == '$') |
| { |
| if ((flag_openmp || flag_openmp_simd) |
| && !flag_openacc) |
| { |
| if (!verify_token_fixed ("omp", 3, last_was_use_stmt)) |
| return ST_NONE; |
| return decode_omp_directive (); |
| } |
| else if ((flag_openmp || flag_openmp_simd) |
| && flag_openacc) |
| { |
| c = gfc_next_char_literal(NONSTRING); |
| if (c == 'o' || c == 'O') |
| { |
| if (!verify_token_fixed ("mp", 2, last_was_use_stmt)) |
| return ST_NONE; |
| return decode_omp_directive (); |
| } |
| else if (c == 'a' || c == 'A') |
| { |
| if (!verify_token_fixed ("cc", 2, last_was_use_stmt)) |
| return ST_NONE; |
| return decode_oacc_directive (); |
| } |
| } |
| else if (flag_openacc) |
| { |
| if (!verify_token_fixed ("acc", 3, last_was_use_stmt)) |
| return ST_NONE; |
| return decode_oacc_directive (); |
| } |
| } |
| gcc_fallthrough (); |
| |
| /* Comments have already been skipped by the time we get |
| here so don't bother checking for them. */ |
| |
| default: |
| gfc_buffer_error (false); |
| gfc_error ("Non-numeric character in statement label at %C"); |
| return ST_NONE; |
| } |
| } |
| |
| if (digit_flag) |
| { |
| if (label == 0) |
| gfc_warning_now (0, "Zero is not a valid statement label at %C"); |
| else |
| { |
| /* We've found a valid statement label. */ |
| gfc_statement_label = gfc_get_st_label (label); |
| } |
| } |
| |
| /* Since this line starts a statement, it cannot be a continuation |
| of a previous statement. If we see something here besides a |
| space or zero, it must be a bad continuation line. */ |
| |
| c = gfc_next_char_literal (NONSTRING); |
| if (c == '\n') |
| goto blank_line; |
| |
| if (c != ' ' && c != '0') |
| { |
| gfc_buffer_error (false); |
| gfc_error ("Bad continuation line at %C"); |
| return ST_NONE; |
| } |
| |
| /* Now that we've taken care of the statement label columns, we have |
| to make sure that the first nonblank character is not a '!'. If |
| it is, the rest of the line is a comment. */ |
| |
| do |
| { |
| loc = gfc_current_locus; |
| c = gfc_next_char_literal (NONSTRING); |
| } |
| while (gfc_is_whitespace (c)); |
| |
| if (c == '!') |
| goto blank_line; |
| gfc_current_locus = loc; |
| |
| if (c == ';') |
| { |
| if (digit_flag) |
| gfc_error_now ("Semicolon at %C needs to be preceded by statement"); |
| else if (!(gfc_option.allow_std & GFC_STD_F2008)) |
| gfc_error_now ("Fortran 2008: Semicolon at %C without preceding " |
| "statement"); |
| return ST_NONE; |
| } |
| |
| if (gfc_match_eos () == MATCH_YES) |
| goto blank_line; |
| |
| /* At this point, we've got a nonblank statement to parse. */ |
| return decode_statement (); |
| |
| blank_line: |
| if (digit_flag) |
| gfc_error_now ("Statement label without statement at %L", &label_locus); |
| |
| gfc_current_locus.lb->truncated = 0; |
| gfc_advance_line (); |
| return ST_NONE; |
| } |
| |
| |
| /* Return the next non-ST_NONE statement to the caller. We also worry |
| about including files and the ends of include files at this stage. */ |
| |
| static gfc_statement |
| next_statement (void) |
| { |
| gfc_statement st; |
| locus old_locus; |
| |
| gfc_enforce_clean_symbol_state (); |
| |
| gfc_new_block = NULL; |
| |
| gfc_current_ns->old_equiv = gfc_current_ns->equiv; |
| gfc_current_ns->old_data = gfc_current_ns->data; |
| for (;;) |
| { |
| gfc_statement_label = NULL; |
| gfc_buffer_error (true); |
| |
| if (gfc_at_eol ()) |
| gfc_advance_line (); |
| |
| gfc_skip_comments (); |
| |
| if (gfc_at_end ()) |
| { |
| st = ST_NONE; |
| break; |
| } |
| |
| if (gfc_define_undef_line ()) |
| continue; |
| |
| old_locus = gfc_current_locus; |
| |
| st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); |
| |
| if (st != ST_NONE) |
| break; |
| } |
| |
| gfc_buffer_error (false); |
| |
| if (st == ST_GET_FCN_CHARACTERISTICS) |
| { |
| if (gfc_statement_label != NULL) |
| { |
| gfc_free_st_label (gfc_statement_label); |
| gfc_statement_label = NULL; |
| } |
| gfc_current_locus = old_locus; |
| } |
| |
| if (st != ST_NONE) |
| check_statement_label (st); |
| |
| return st; |
| } |
| |
| |
| /****************************** Parser ***********************************/ |
| |
| /* The parser subroutines are of type 'try' that fail if the file ends |
| unexpectedly. */ |
| |
| /* Macros that expand to case-labels for various classes of |
| statements. Start with executable statements that directly do |
| things. */ |
| |
| #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ |
| case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ |
| case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ |
| case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ |
| case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ |
| case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ |
| case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ |
| case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ |
| case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \ |
| case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \ |
| case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \ |
| case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \ |
| case ST_ERROR_STOP: case ST_SYNC_ALL: \ |
| case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ |
| case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ |
| case ST_END_TEAM: case ST_SYNC_TEAM: \ |
| case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ |
| case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ |
| case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA |
| |
| /* Statements that mark other executable statements. */ |
| |
| #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ |
| case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ |
| case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ |
| case ST_OMP_PARALLEL: \ |
| case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ |
| case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ |
| case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ |
| case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ |
| case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \ |
| case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \ |
| case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \ |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \ |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \ |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \ |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \ |
| case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \ |
| case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \ |
| case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \ |
| case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \ |
| case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \ |
| case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \ |
| case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \ |
| case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ |
| case ST_CRITICAL: \ |
| case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ |
| case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ |
| case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC |
| |
| /* Declaration statements */ |
| |
| #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ |
| case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ |
| case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \ |
| case ST_OACC_DECLARE |
| |
| /* OpenMP declaration statements. */ |
| |
| #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ |
| case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION |
| |
| /* Block end statements. Errors associated with interchanging these |
| are detected in gfc_match_end(). */ |
| |
| #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ |
| case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ |
| case ST_END_BLOCK: case ST_END_ASSOCIATE |
| |
| |
| /* Push a new state onto the stack. */ |
| |
| static void |
| push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) |
| { |
| p->state = new_state; |
| p->previous = gfc_state_stack; |
| p->sym = sym; |
| p->head = p->tail = NULL; |
| p->do_variable = NULL; |
| if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT) |
| p->ext.oacc_declare_clauses = NULL; |
| |
| /* If this the state of a construct like BLOCK, DO or IF, the corresponding |
| construct statement was accepted right before pushing the state. Thus, |
| the construct's gfc_code is available as tail of the parent state. */ |
| gcc_assert (gfc_state_stack); |
| p->construct = gfc_state_stack->tail; |
| |
| gfc_state_stack = p; |
| } |
| |
| |
| /* Pop the current state. */ |
| static void |
| pop_state (void) |
| { |
| gfc_state_stack = gfc_state_stack->previous; |
| } |
| |
| |
| /* Try to find the given state in the state stack. */ |
| |
| bool |
| gfc_find_state (gfc_compile_state state) |
| { |
| gfc_state_data *p; |
| |
| for (p = gfc_state_stack; p; p = p->previous) |
| if (p->state == state) |
| break; |
| |
| return (p == NULL) ? false : true; |
| } |
| |
| |
| /* Starts a new level in the statement list. */ |
| |
| static gfc_code * |
| new_level (gfc_code *q) |
| { |
| gfc_code *p; |
| |
| p = q->block = gfc_get_code (EXEC_NOP); |
| |
| gfc_state_stack->head = gfc_state_stack->tail = p; |
| |
| return p; |
| } |
| |
| |
| /* Add the current new_st code structure and adds it to the current |
| program unit. As a side-effect, it zeroes the new_st. */ |
| |
| static gfc_code * |
| add_statement (void) |
| { |
| gfc_code *p; |
| |
| p = XCNEW (gfc_code); |
| *p = new_st; |
| |
| p->loc = gfc_current_locus; |
| |
| if (gfc_state_stack->head == NULL) |
| gfc_state_stack->head = p; |
| else |
| gfc_state_stack->tail->next = p; |
| |
| while (p->next != NULL) |
| p = p->next; |
| |
| gfc_state_stack->tail = p; |
| |
| gfc_clear_new_st (); |
| |
| return p; |
| } |
| |
| |
| /* Frees everything associated with the current statement. */ |
| |
| static void |
| undo_new_statement (void) |
| { |
| gfc_free_statements (new_st.block); |
| gfc_free_statements (new_st.next); |
| gfc_free_statement (&new_st); |
| gfc_clear_new_st (); |
| } |
| |
| |
| /* If the current statement has a statement label, make sure that it |
| is allowed to, or should have one. */ |
| |
| static void |
| check_statement_label (gfc_statement st) |
| { |
| gfc_sl_type type; |
| |
| if (gfc_statement_label == NULL) |
| { |
| if (st == ST_FORMAT) |
| gfc_error ("FORMAT statement at %L does not have a statement label", |
| &new_st.loc); |
| return; |
| } |
| |
| switch (st) |
| { |
| case ST_END_PROGRAM: |
| case ST_END_FUNCTION: |
| case ST_END_SUBROUTINE: |
| case ST_ENDDO: |
| case ST_ENDIF: |
| case ST_END_SELECT: |
| case ST_END_CRITICAL: |
| case ST_END_BLOCK: |
| case ST_END_ASSOCIATE: |
| case_executable: |
| case_exec_markers: |
| if (st == ST_ENDDO || st == ST_CONTINUE) |
| type = ST_LABEL_DO_TARGET; |
| else |
| type = ST_LABEL_TARGET; |
| break; |
| |
| case ST_FORMAT: |
| type = ST_LABEL_FORMAT; |
| break; |
| |
| /* Statement labels are not restricted from appearing on a |
| particular line. However, there are plenty of situations |
| where the resulting label can't be referenced. */ |
| |
| default: |
| type = ST_LABEL_BAD_TARGET; |
| break; |
| } |
| |
| gfc_define_st_label (gfc_statement_label, type, &label_locus); |
| |
| new_st.here = gfc_statement_label; |
| } |
| |
| |
| /* Figures out what the enclosing program unit is. This will be a |
| function, subroutine, program, block data or module. */ |
| |
| gfc_state_data * |
| gfc_enclosing_unit (gfc_compile_state * result) |
| { |
| gfc_state_data *p; |
| |
| for (p = gfc_state_stack; p; p = p->previous) |
| if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE |
| || p->state == COMP_MODULE || p->state == COMP_SUBMODULE |
| || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM) |
| { |
| |
| if (result != NULL) |
| *result = p->state; |
| return p; |
| } |
| |
| if (result != NULL) |
| *result = COMP_PROGRAM; |
| return NULL; |
| } |
| |
| |
| /* Translate a statement enum to a string. */ |
| |
| const char * |
| gfc_ascii_statement (gfc_statement st) |
| { |
| const char *p; |
| |
| switch (st) |
| { |
| case ST_ARITHMETIC_IF: |
| p = _("arithmetic IF"); |
| break; |
| case ST_ALLOCATE: |
| p = "ALLOCATE"; |
| break; |
| case ST_ASSOCIATE: |
| p = "ASSOCIATE"; |
| break; |
| case ST_ATTR_DECL: |
| p = _("attribute declaration"); |
| break; |
| case ST_BACKSPACE: |
| p = "BACKSPACE"; |
| break; |
| case ST_BLOCK: |
| p = "BLOCK"; |
| break; |
| case ST_BLOCK_DATA: |
| p = "BLOCK DATA"; |
| break; |
| case ST_CALL: |
| p = "CALL"; |
| break; |
| case ST_CASE: |
| p = "CASE"; |
| break; |
| case ST_CLOSE: |
| p = "CLOSE"; |
| break; |
| case ST_COMMON: |
| p = "COMMON"; |
| break; |
| case ST_CONTINUE: |
| p = "CONTINUE"; |
| break; |
| case ST_CONTAINS: |
| p = "CONTAINS"; |
| break; |
| case ST_CRITICAL: |
| p = "CRITICAL"; |
| break; |
| case ST_CYCLE: |
| p = "CYCLE"; |
| break; |
| case ST_DATA_DECL: |
| p = _("data declaration"); |
| break; |
| case ST_DATA: |
| p = "DATA"; |
| break; |
| case ST_DEALLOCATE: |
| p = "DEALLOCATE"; |
| break; |
| case ST_MAP: |
| p = "MAP"; |
| break; |
| case ST_UNION: |
| p = "UNION"; |
| break; |
| case ST_STRUCTURE_DECL: |
| p = "STRUCTURE"; |
| break; |
| case ST_DERIVED_DECL: |
| p = _("derived type declaration"); |
| break; |
| case ST_DO: |
| p = "DO"; |
| break; |
| case ST_ELSE: |
| p = "ELSE"; |
| break; |
| case ST_ELSEIF: |
| p = "ELSE IF"; |
| break; |
| case ST_ELSEWHERE: |
| p = "ELSEWHERE"; |
| break; |
| case ST_EVENT_POST: |
| p = "EVENT POST"; |
| break; |
| case ST_EVENT_WAIT: |
| p = "EVENT WAIT"; |
| break; |
| case ST_FAIL_IMAGE: |
| p = "FAIL IMAGE"; |
| break; |
| case ST_CHANGE_TEAM: |
| p = "CHANGE TEAM"; |
| break; |
| case ST_END_TEAM: |
| p = "END TEAM"; |
| break; |
| case ST_FORM_TEAM: |
| p = "FORM TEAM"; |
| break; |
| case ST_SYNC_TEAM: |
| p = "SYNC TEAM"; |
| break; |
| case ST_END_ASSOCIATE: |
| p = "END ASSOCIATE"; |
| break; |
| case ST_END_BLOCK: |
| p = "END BLOCK"; |
| break; |
| case ST_END_BLOCK_DATA: |
| p = "END BLOCK DATA"; |
| break; |
| case ST_END_CRITICAL: |
| p = "END CRITICAL"; |
| break; |
| case ST_ENDDO: |
| p = "END DO"; |
| break; |
| case ST_END_FILE: |
| p = "END FILE"; |
| break; |
| case ST_END_FORALL: |
| p = "END FORALL"; |
| break; |
| case ST_END_FUNCTION: |
| p = "END FUNCTION"; |
| break; |
| case ST_ENDIF: |
| p = "END IF"; |
| break; |
| case ST_END_INTERFACE: |
| p = "END INTERFACE"; |
| break; |
| case ST_END_MODULE: |
| p = "END MODULE"; |
| break; |
| case ST_END_SUBMODULE: |
| p = "END SUBMODULE"; |
| break; |
| case ST_END_PROGRAM: |
| p = "END PROGRAM"; |
| break; |
| case ST_END_SELECT: |
| p = "END SELECT"; |
| break; |
| case ST_END_SUBROUTINE: |
| p = "END SUBROUTINE"; |
| break; |
| case ST_END_WHERE: |
| p = "END WHERE"; |
| break; |
| case ST_END_STRUCTURE: |
| p = "END STRUCTURE"; |
| break; |
| case ST_END_UNION: |
| p = "END UNION"; |
| break; |
| case ST_END_MAP: |
| p = "END MAP"; |
| break; |
| case ST_END_TYPE: |
| p = "END TYPE"; |
| break; |
| case ST_ENTRY: |
| p = "ENTRY"; |
| break; |
| case ST_EQUIVALENCE: |
| p = "EQUIVALENCE"; |
| break; |
| case ST_ERROR_STOP: |
| p = "ERROR STOP"; |
| break; |
| case ST_EXIT: |
| p = "EXIT"; |
| break; |
| case ST_FLUSH: |
| p = "FLUSH"; |
| break; |
| case ST_FORALL_BLOCK: /* Fall through */ |
| case ST_FORALL: |
| p = "FORALL"; |
| break; |
| case ST_FORMAT: |
| p = "FORMAT"; |
| break; |
| case ST_FUNCTION: |
| p = "FUNCTION"; |
| break; |
| case ST_GENERIC: |
| p = "GENERIC"; |
| break; |
| case ST_GOTO: |
| p = "GOTO"; |
| break; |
| case ST_IF_BLOCK: |
| p = _("block IF"); |
| break; |
| case ST_IMPLICIT: |
| p = "IMPLICIT"; |
| break; |
| case ST_IMPLICIT_NONE: |
| p = "IMPLICIT NONE"; |
| break; |
| case ST_IMPLIED_ENDDO: |
| p = _("implied END DO"); |
| break; |
| case ST_IMPORT: |
| p = "IMPORT"; |
| break; |
| case ST_INQUIRE: |
| p = "INQUIRE"; |
| break; |
| case ST_INTERFACE: |
| p = "INTERFACE"; |
| break; |
| case ST_LOCK: |
| p = "LOCK"; |
| break; |
| case ST_PARAMETER: |
| p = "PARAMETER"; |
| break; |
| case ST_PRIVATE: |
| p = "PRIVATE"; |
| break; |
| case ST_PUBLIC: |
| p = "PUBLIC"; |
| break; |
| case ST_MODULE: |
| p = "MODULE"; |
| break; |
| case ST_SUBMODULE: |
| p = "SUBMODULE"; |
| break; |
| case ST_PAUSE: |
| p = "PAUSE"; |
| break; |
| case ST_MODULE_PROC: |
| p = "MODULE PROCEDURE"; |
| break; |
| case ST_NAMELIST: |
| p = "NAMELIST"; |
| break; |
| case ST_NULLIFY: |
| p = "NULLIFY"; |
| break; |
| case ST_OPEN: |
| p = "OPEN"; |
| break; |
| case ST_PROGRAM: |
| p = "PROGRAM"; |
| break; |
| case ST_PROCEDURE: |
| p = "PROCEDURE"; |
| break; |
| case ST_READ: |
| p = "READ"; |
| break; |
| case ST_RETURN: |
| p = "RETURN"; |
| break; |
| case ST_REWIND: |
| p = "REWIND"; |
| break; |
| case ST_STOP: |
| p = "STOP"; |
| break; |
| case ST_SYNC_ALL: |
| p = "SYNC ALL"; |
| break; |
| case ST_SYNC_IMAGES: |
| p = "SYNC IMAGES"; |
| break; |
| case ST_SYNC_MEMORY: |
| p = "SYNC MEMORY"; |
| break; |
| case ST_SUBROUTINE: |
| p = "SUBROUTINE"; |
| break; |
| case ST_TYPE: |
| p = "TYPE"; |
| break; |
| case ST_UNLOCK: |
| p = "UNLOCK"; |
| break; |
| case ST_USE: |
| p = "USE"; |
| break; |
| case ST_WHERE_BLOCK: /* Fall through */ |
| case ST_WHERE: |
| p = "WHERE"; |
| break; |
| case ST_WAIT: |
| p = "WAIT"; |
| break; |
| case ST_WRITE: |
| p = "WRITE"; |
| break; |
| case ST_ASSIGNMENT: |
| p = _("assignment"); |
| break; |
| case ST_POINTER_ASSIGNMENT: |
| p = _("pointer assignment"); |
| break; |
| case ST_SELECT_CASE: |
| p = "SELECT CASE"; |
| break; |
| case ST_SELECT_TYPE: |
| p = "SELECT TYPE"; |
| break; |
| case ST_TYPE_IS: |
| p = "TYPE IS"; |
| break; |
| case ST_CLASS_IS: |
| p = "CLASS IS"; |
| break; |
| case ST_SEQUENCE: |
| p = "SEQUENCE"; |
| break; |
| case ST_SIMPLE_IF: |
| p = _("simple IF"); |
| break; |
| case ST_STATEMENT_FUNCTION: |
| p = "STATEMENT FUNCTION"; |
| break; |
| case ST_LABEL_ASSIGNMENT: |
| p = "LABEL ASSIGNMENT"; |
| break; |
| case ST_ENUM: |
| p = "ENUM DEFINITION"; |
| break; |
| case ST_ENUMERATOR: |
| p = "ENUMERATOR DEFINITION"; |
| break; |
| case ST_END_ENUM: |
| p = "END ENUM"; |
| break; |
| case ST_OACC_PARALLEL_LOOP: |
| p = "!$ACC PARALLEL LOOP"; |
| break; |
| case ST_OACC_END_PARALLEL_LOOP: |
| p = "!$ACC END PARALLEL LOOP"; |
| break; |
| case ST_OACC_PARALLEL: |
| p = "!$ACC PARALLEL"; |
| break; |
| case ST_OACC_END_PARALLEL: |
| p = "!$ACC END PARALLEL"; |
| break; |
| case ST_OACC_KERNELS: |
| p = "!$ACC KERNELS"; |
| break; |
| case ST_OACC_END_KERNELS: |
| p = "!$ACC END KERNELS"; |
| break; |
| case ST_OACC_KERNELS_LOOP: |
| p = "!$ACC KERNELS LOOP"; |
| break; |
| case ST_OACC_END_KERNELS_LOOP: |
| p = "!$ACC END KERNELS LOOP"; |
| break; |
| case ST_OACC_DATA: |
| p = "!$ACC DATA"; |
| break; |
| case ST_OACC_END_DATA: |
| p = "!$ACC END DATA"; |
| break; |
| case ST_OACC_HOST_DATA: |
| p = "!$ACC HOST_DATA"; |
| break; |
| case ST_OACC_END_HOST_DATA: |
| p = "!$ACC END HOST_DATA"; |
| break; |
| case ST_OACC_LOOP: |
| p = "!$ACC LOOP"; |
| break; |
| case ST_OACC_END_LOOP: |
| p = "!$ACC END LOOP"; |
| break; |
| case ST_OACC_DECLARE: |
| p = "!$ACC DECLARE"; |
| break; |
| case ST_OACC_UPDATE: |
| p = "!$ACC UPDATE"; |
| break; |
| case ST_OACC_WAIT: |
| p = "!$ACC WAIT"; |
| break; |
| case ST_OACC_CACHE: |
| p = "!$ACC CACHE"; |
| break; |
| case ST_OACC_ENTER_DATA: |
| p = "!$ACC ENTER DATA"; |
| break; |
| case ST_OACC_EXIT_DATA: |
| p = "!$ACC EXIT DATA"; |
| break; |
| case ST_OACC_ROUTINE: |
| p = "!$ACC ROUTINE"; |
| break; |
| case ST_OACC_ATOMIC: |
| p = "!$ACC ATOMIC"; |
| break; |
| case ST_OACC_END_ATOMIC: |
| p = "!$ACC END ATOMIC"; |
| break; |
| case ST_OMP_ATOMIC: |
| p = "!$OMP ATOMIC"; |
| break; |
| case ST_OMP_BARRIER: |
| p = "!$OMP BARRIER"; |
| break; |
| case ST_OMP_CANCEL: |
| p = "!$OMP CANCEL"; |
| break; |
| case ST_OMP_CANCELLATION_POINT: |
| p = "!$OMP CANCELLATION POINT"; |
| break; |
| case ST_OMP_CRITICAL: |
| p = "!$OMP CRITICAL"; |
| break; |
| case ST_OMP_DECLARE_REDUCTION: |
| p = "!$OMP DECLARE REDUCTION"; |
| break; |
| case ST_OMP_DECLARE_SIMD: |
| p = "!$OMP DECLARE SIMD"; |
| break; |
| case ST_OMP_DECLARE_TARGET: |
| p = "!$OMP DECLARE TARGET"; |
| break; |
| case ST_OMP_DISTRIBUTE: |
| p = "!$OMP DISTRIBUTE"; |
| break; |
| case ST_OMP_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_DISTRIBUTE_SIMD: |
| p = "!$OMP DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_DO: |
| p = "!$OMP DO"; |
| break; |
| case ST_OMP_DO_SIMD: |
| p = "!$OMP DO SIMD"; |
| break; |
| case ST_OMP_END_ATOMIC: |
| p = "!$OMP END ATOMIC"; |
| break; |
| case ST_OMP_END_CRITICAL: |
| p = "!$OMP END CRITICAL"; |
| break; |
| case ST_OMP_END_DISTRIBUTE: |
| p = "!$OMP END DISTRIBUTE"; |
| break; |
| case ST_OMP_END_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP END DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_END_DISTRIBUTE_SIMD: |
| p = "!$OMP END DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_END_DO: |
| p = "!$OMP END DO"; |
| break; |
| case ST_OMP_END_DO_SIMD: |
| p = "!$OMP END DO SIMD"; |
| break; |
| case ST_OMP_END_SIMD: |
| p = "!$OMP END SIMD"; |
| break; |
| case ST_OMP_END_MASTER: |
| p = "!$OMP END MASTER"; |
| break; |
| case ST_OMP_END_ORDERED: |
| p = "!$OMP END ORDERED"; |
| break; |
| case ST_OMP_END_PARALLEL: |
| p = "!$OMP END PARALLEL"; |
| break; |
| case ST_OMP_END_PARALLEL_DO: |
| p = "!$OMP END PARALLEL DO"; |
| break; |
| case ST_OMP_END_PARALLEL_DO_SIMD: |
| p = "!$OMP END PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_END_PARALLEL_SECTIONS: |
| p = "!$OMP END PARALLEL SECTIONS"; |
| break; |
| case ST_OMP_END_PARALLEL_WORKSHARE: |
| p = "!$OMP END PARALLEL WORKSHARE"; |
| break; |
| case ST_OMP_END_SECTIONS: |
| p = "!$OMP END SECTIONS"; |
| break; |
| case ST_OMP_END_SINGLE: |
| p = "!$OMP END SINGLE"; |
| break; |
| case ST_OMP_END_TASK: |
| p = "!$OMP END TASK"; |
| break; |
| case ST_OMP_END_TARGET: |
| p = "!$OMP END TARGET"; |
| break; |
| case ST_OMP_END_TARGET_DATA: |
| p = "!$OMP END TARGET DATA"; |
| break; |
| case ST_OMP_END_TARGET_PARALLEL: |
| p = "!$OMP END TARGET PARALLEL"; |
| break; |
| case ST_OMP_END_TARGET_PARALLEL_DO: |
| p = "!$OMP END TARGET PARALLEL DO"; |
| break; |
| case ST_OMP_END_TARGET_PARALLEL_DO_SIMD: |
| p = "!$OMP END TARGET PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_END_TARGET_SIMD: |
| p = "!$OMP END TARGET SIMD"; |
| break; |
| case ST_OMP_END_TARGET_TEAMS: |
| p = "!$OMP END TARGET TEAMS"; |
| break; |
| case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE: |
| p = "!$OMP END TARGET TEAMS DISTRIBUTE"; |
| break; |
| case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_END_TASKGROUP: |
| p = "!$OMP END TASKGROUP"; |
| break; |
| case ST_OMP_END_TASKLOOP: |
| p = "!$OMP END TASKLOOP"; |
| break; |
| case ST_OMP_END_TASKLOOP_SIMD: |
| p = "!$OMP END TASKLOOP SIMD"; |
| break; |
| case ST_OMP_END_TEAMS: |
| p = "!$OMP END TEAMS"; |
| break; |
| case ST_OMP_END_TEAMS_DISTRIBUTE: |
| p = "!$OMP END TEAMS DISTRIBUTE"; |
| break; |
| case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD: |
| p = "!$OMP END TEAMS DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_END_WORKSHARE: |
| p = "!$OMP END WORKSHARE"; |
| break; |
| case ST_OMP_FLUSH: |
| p = "!$OMP FLUSH"; |
| break; |
| case ST_OMP_MASTER: |
| p = "!$OMP MASTER"; |
| break; |
| case ST_OMP_ORDERED: |
| case ST_OMP_ORDERED_DEPEND: |
| p = "!$OMP ORDERED"; |
| break; |
| case ST_OMP_PARALLEL: |
| p = "!$OMP PARALLEL"; |
| break; |
| case ST_OMP_PARALLEL_DO: |
| p = "!$OMP PARALLEL DO"; |
| break; |
| case ST_OMP_PARALLEL_DO_SIMD: |
| p = "!$OMP PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_PARALLEL_SECTIONS: |
| p = "!$OMP PARALLEL SECTIONS"; |
| break; |
| case ST_OMP_PARALLEL_WORKSHARE: |
| p = "!$OMP PARALLEL WORKSHARE"; |
| break; |
| case ST_OMP_SECTIONS: |
| p = "!$OMP SECTIONS"; |
| break; |
| case ST_OMP_SECTION: |
| p = "!$OMP SECTION"; |
| break; |
| case ST_OMP_SIMD: |
| p = "!$OMP SIMD"; |
| break; |
| case ST_OMP_SINGLE: |
| p = "!$OMP SINGLE"; |
| break; |
| case ST_OMP_TARGET: |
| p = "!$OMP TARGET"; |
| break; |
| case ST_OMP_TARGET_DATA: |
| p = "!$OMP TARGET DATA"; |
| break; |
| case ST_OMP_TARGET_ENTER_DATA: |
| p = "!$OMP TARGET ENTER DATA"; |
| break; |
| case ST_OMP_TARGET_EXIT_DATA: |
| p = "!$OMP TARGET EXIT DATA"; |
| break; |
| case ST_OMP_TARGET_PARALLEL: |
| p = "!$OMP TARGET PARALLEL"; |
| break; |
| case ST_OMP_TARGET_PARALLEL_DO: |
| p = "!$OMP TARGET PARALLEL DO"; |
| break; |
| case ST_OMP_TARGET_PARALLEL_DO_SIMD: |
| p = "!$OMP TARGET PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_TARGET_SIMD: |
| p = "!$OMP TARGET SIMD"; |
| break; |
| case ST_OMP_TARGET_TEAMS: |
| p = "!$OMP TARGET TEAMS"; |
| break; |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE: |
| p = "!$OMP TARGET TEAMS DISTRIBUTE"; |
| break; |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: |
| p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_TARGET_UPDATE: |
| p = "!$OMP TARGET UPDATE"; |
| break; |
| case ST_OMP_TASK: |
| p = "!$OMP TASK"; |
| break; |
| case ST_OMP_TASKGROUP: |
| p = "!$OMP TASKGROUP"; |
| break; |
| case ST_OMP_TASKLOOP: |
| p = "!$OMP TASKLOOP"; |
| break; |
| case ST_OMP_TASKLOOP_SIMD: |
| p = "!$OMP TASKLOOP SIMD"; |
| break; |
| case ST_OMP_TASKWAIT: |
| p = "!$OMP TASKWAIT"; |
| break; |
| case ST_OMP_TASKYIELD: |
| p = "!$OMP TASKYIELD"; |
| break; |
| case ST_OMP_TEAMS: |
| p = "!$OMP TEAMS"; |
| break; |
| case ST_OMP_TEAMS_DISTRIBUTE: |
| p = "!$OMP TEAMS DISTRIBUTE"; |
| break; |
| case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: |
| p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO"; |
| break; |
| case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: |
| p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD"; |
| break; |
| case ST_OMP_TEAMS_DISTRIBUTE_SIMD: |
| p = "!$OMP TEAMS DISTRIBUTE SIMD"; |
| break; |
| case ST_OMP_THREADPRIVATE: |
| p = "!$OMP THREADPRIVATE"; |
| break; |
| case ST_OMP_WORKSHARE: |
| p = "!$OMP WORKSHARE"; |
| break; |
| default: |
| gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); |
| } |
| |
| return p; |
| } |
| |
| |
| /* Create a symbol for the main program and assign it to ns->proc_name. */ |
| |
| static void |
| main_program_symbol (gfc_namespace *ns, const char *name) |
| { |
| gfc_symbol *main_program; |
| symbol_attribute attr; |
| |
| gfc_get_symbol (name, ns, &main_program); |
| gfc_clear_attr (&attr); |
| attr.flavor = FL_PROGRAM; |
| attr.proc = PROC_UNKNOWN; |
| attr.subroutine = 1; |
| attr.access = ACCESS_PUBLIC; |
| attr.is_main_program = 1; |
| main_program->attr = attr; |
| main_program->declared_at = gfc_current_locus; |
| ns->proc_name = main_program; |
| gfc_commit_symbols (); |
| } |
| |
| |
| /* Do whatever is necessary to accept the last statement. */ |
| |
| static void |
| accept_statement (gfc_statement st) |
| { |
| switch (st) |
| { |
| case ST_IMPLICIT_NONE: |
| case ST_IMPLICIT: |
| break; |
| |
| case ST_FUNCTION: |
| case ST_SUBROUTINE: |
| case ST_MODULE: |
| case ST_SUBMODULE: |
| gfc_current_ns->proc_name = gfc_new_block; |
| break; |
| |
| /* If the statement is the end of a block, lay down a special code |
| that allows a branch to the end of the block from within the |
| construct. IF and SELECT are treated differently from DO |
| (where EXEC_NOP is added inside the loop) for two |
| reasons: |
| 1. END DO has a meaning in the sense that after a GOTO to |
| it, the loop counter must be increased. |
| 2. IF blocks and SELECT blocks can consist of multiple |
| parallel blocks (IF ... ELSE IF ... ELSE ... END IF). |
| Putting the label before the END IF would make the jump |
| from, say, the ELSE IF block to the END IF illegal. */ |
| |
| case ST_ENDIF: |
| case ST_END_SELECT: |
| case ST_END_CRITICAL: |
| if (gfc_statement_label != NULL) |
| { |
| new_st.op = EXEC_END_NESTED_BLOCK; |
| add_statement (); |
| } |
| break; |
| |
| /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than |
| one parallel block. Thus, we add the special code to the nested block |
| itself, instead of the parent one. */ |
| case ST_END_BLOCK: |
| case ST_END_ASSOCIATE: |
| if (gfc_statement_label != NULL) |
| { |
| new_st.op = EXEC_END_BLOCK; |
| add_statement (); |
| } |
| break; |
| |
| /* The end-of-program unit statements do not get the special |
| marker and require a statement of some sort if they are a |
| branch target. */ |
| |
| case ST_END_PROGRAM: |
| case ST_END_FUNCTION: |
| case ST_END_SUBROUTINE: |
| if (gfc_statement_label != NULL) |
| { |
| new_st.op = EXEC_RETURN; |
| add_statement (); |
| } |
| else |
| { |
| new_st.op = EXEC_END_PROCEDURE; |
| add_statement (); |
| } |
| |
| break; |
| |
| case ST_ENTRY: |
| case_executable: |
| case_exec_markers: |
| add_statement (); |
| break; |
| |
| default: |
| break; |
| } |
| |
| gfc_commit_symbols (); |
| gfc_warning_check (); |
| gfc_clear_new_st (); |
| } |
| |
| |
| /* Undo anything tentative that has been built for the current statement, |
| except if a gfc_charlen structure has been added to current namespace's |
| list of gfc_charlen structure. */ |
| |
| static void |
| reject_statement (void) |
| { |
| gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv); |
| gfc_current_ns->equiv = gfc_current_ns->old_equiv; |
| |
| gfc_reject_data (gfc_current_ns); |
| |
| gfc_new_block = NULL; |
| gfc_undo_symbols (); |
| gfc_clear_warning (); |
| undo_new_statement (); |
| } |
| |
| |
| /* Generic complaint about an out of order statement. We also do |
| whatever is necessary to clean up. */ |
| |
| static void |
| unexpected_statement (gfc_statement st) |
| { |
| gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); |
| |
| reject_statement (); |
| } |
| |
| |
| /* Given the next statement seen by the matcher, make sure that it is |
| in proper order with the last. This subroutine is initialized by |
| calling it with an argument of ST_NONE. If there is a problem, we |
| issue an error and return false. Otherwise we return true. |
| |
| Individual parsers need to verify that the statements seen are |
| valid before calling here, i.e., ENTRY statements are not allowed in |
| INTERFACE blocks. The following diagram is taken from the standard: |
| |
| +---------------------------------------+ |
| | program subroutine function module | |
| +---------------------------------------+ |
| | use | |
| +---------------------------------------+ |
| | import | |
| +---------------------------------------+ |
| | | implicit none | |
| | +-----------+------------------+ |
| | | parameter | implicit | |
| | +-----------+------------------+ |
| | format | | derived type | |
| | entry | parameter | interface | |
| | | data | specification | |
| | | | statement func | |
| | +-----------+------------------+ |
| | | data | executable | |
| +--------+-----------+------------------+ |
| | contains | |
| +---------------------------------------+ |
| | internal module/subprogram | |
| +---------------------------------------+ |
| | end | |
| +---------------------------------------+ |
| |
| */ |
| |
| enum state_order |
| { |
| ORDER_START, |
| ORDER_USE, |
| ORDER_IMPORT, |
| ORDER_IMPLICIT_NONE, |
| ORDER_IMPLICIT, |
| ORDER_SPEC, |
| ORDER_EXEC |
| }; |
| |
| typedef struct |
| { |
| enum state_order state; |
| gfc_statement last_statement; |
| locus where; |
| } |
| st_state; |
| |
| static bool |
| verify_st_order (st_state *p, gfc_statement st, bool silent) |
| { |
| |
| switch (st) |
| { |
| case ST_NONE: |
| p->state = ORDER_START; |
| break; |
| |
| case ST_USE: |
| if (p->state > ORDER_USE) |
| goto order; |
| p->state = ORDER_USE; |
| break; |
| |
| case ST_IMPORT: |
| if (p->state > ORDER_IMPORT) |
| goto order; |
| p->state = ORDER_IMPORT; |
| break; |
| |
| case ST_IMPLICIT_NONE: |
| if (p->state > ORDER_IMPLICIT) |
| goto order; |
| |
| /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY |
| statement disqualifies a USE but not an IMPLICIT NONE. |
| Duplicate IMPLICIT NONEs are caught when the implicit types |
| are set. */ |
| |
| p->state = ORDER_IMPLICIT_NONE; |
| break; |
| |
| case ST_IMPLICIT: |
| if (p->state > ORDER_IMPLICIT) |
| goto order; |
| p->state = ORDER_IMPLICIT; |
| break; |
| |
| case ST_FORMAT: |
| case ST_ENTRY: |
| if (p->state < ORDER_IMPLICIT_NONE) |
| p->state = ORDER_IMPLICIT_NONE; |
| break; |
| |
| case ST_PARAMETER: |
| if (p->state >= ORDER_EXEC) |
| goto order; |
| if (p->state < ORDER_IMPLICIT) |
| p->state = ORDER_IMPLICIT; |
| break; |
| |
| case ST_DATA: |
| if (p->state < ORDER_SPEC) |
| p->state = ORDER_SPEC; |
| break; |
| |
| case ST_PUBLIC: |
| case ST_PRIVATE: |
| case ST_STRUCTURE_DECL: |
| case ST_DERIVED_DECL: |
| case_decl: |
| if (p->state >= ORDER_EXEC) |
| goto order; |
| if (p->state < ORDER_SPEC) |
| p->state = ORDER_SPEC; |
| break; |
| |
| case_omp_decl: |
| /* The OpenMP directives have to be somewhere in the specification |
| part, but there are no further requirements on their ordering. |
| Thus don't adjust p->state, just ignore them. */ |
| if (p->state >= ORDER_EXEC) |
| goto order; |
| break; |
| |
| case_executable: |
| case_exec_markers: |
| if (p->state < ORDER_EXEC) |
| p->state = ORDER_EXEC; |
| break; |
| |
| default: |
| return false; |
| } |
| |
| /* All is well, record the statement in case we need it next time. */ |
| p->where = gfc_current_locus; |
| p->last_statement = st; |
| return true; |
| |
| order: |
| if (!silent) |
| gfc_error ("%s statement at %C cannot follow %s statement at %L", |
| gfc_ascii_statement (st), |
| gfc_ascii_statement (p->last_statement), &p->where); |
| |
| return false; |
| } |
| |
| |
| /* Handle an unexpected end of file. This is a show-stopper... */ |
| |
| static void unexpected_eof (void) ATTRIBUTE_NORETURN; |
| |
| static void |
| unexpected_eof (void) |
| { |
| gfc_state_data *p; |
| |
| gfc_error ("Unexpected end of file in %qs", gfc_source_file); |
| |
| /* Memory cleanup. Move to "second to last". */ |
| for (p = gfc_state_stack; p && p->previous && p->previous->previous; |
| p = p->previous); |
| |
| gfc_current_ns->code = (p && p->previous) ? p->head : NULL; |
| gfc_done_2 (); |
| |
| longjmp (eof_buf, 1); |
| |
| /* Avoids build error on systems where longjmp is not declared noreturn. */ |
| gcc_unreachable (); |
| } |
| |
| |
| /* Parse the CONTAINS section of a derived type definition. */ |
| |
| gfc_access gfc_typebound_default_access; |
| |
| static bool |
| parse_derived_contains (void) |
| { |
| gfc_state_data s; |
| bool seen_private = false; |
| bool seen_comps = false; |
| bool error_flag = false; |
| bool to_finish; |
| |
| gcc_assert (gfc_current_state () == COMP_DERIVED); |
| gcc_assert (gfc_current_block ()); |
| |
| /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS |
| section. */ |
| if (gfc_current_block ()->attr.sequence) |
| gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS" |
| " section at %C", gfc_current_block ()->name); |
| if (gfc_current_block ()->attr.is_bind_c) |
| gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS" |
| " section at %C", gfc_current_block ()->name); |
| |
| accept_statement (ST_CONTAINS); |
| push_state (&s, COMP_DERIVED_CONTAINS, NULL); |
| |
| gfc_typebound_default_access = ACCESS_PUBLIC; |
| |
| to_finish = false; |
| while (!to_finish) |
| { |
| gfc_statement st; |
| st = next_statement (); |
| switch (st) |
| { |
| case ST_NONE: |
| unexpected_eof (); |
| break; |
| |
| case ST_DATA_DECL: |
| gfc_error ("Components in TYPE at %C must precede CONTAINS"); |
| goto error; |
| |
| case ST_PROCEDURE: |
| if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C")) |
| goto error; |
| |
| accept_statement (ST_PROCEDURE); |
| seen_comps = true; |
| break; |
| |
| case ST_GENERIC: |
| if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C")) |
| goto error; |
| |
| accept_statement (ST_GENERIC); |
| seen_comps = true; |
| break; |
| |
| case ST_FINAL: |
| if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration" |
| " at %C")) |
| goto error; |
| |
| accept_statement (ST_FINAL); |
| seen_comps = true; |
| break; |
| |
| case ST_END_TYPE: |
| to_finish = true; |
| |
| if (!seen_comps |
| && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition " |
| "at %C with empty CONTAINS section"))) |
| goto error; |
| |
| /* ST_END_TYPE is accepted by parse_derived after return. */ |
| break; |
| |
| case ST_PRIVATE: |
| if (!gfc_find_state (COMP_MODULE)) |
| { |
| gfc_error ("PRIVATE statement in TYPE at %C must be inside " |
| "a MODULE"); |
| goto error; |
| } |
| |
| if (seen_comps) |
| { |
| gfc_error ("PRIVATE statement at %C must precede procedure" |
| " bindings"); |
| goto error; |
| } |
| |
| if (seen_private) |
| { |
| gfc_error ("Duplicate PRIVATE statement at %C"); |
| goto error; |
| } |
| |
| accept_statement (ST_PRIVATE); |
| gfc_typebound_default_access = ACCESS_PRIVATE; |
| seen_private = true; |
| break; |
| |
| case ST_SEQUENCE: |
| gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); |
| goto error; |
| |
| case ST_CONTAINS: |
| gfc_error ("Already inside a CONTAINS block at %C"); |
| goto error; |
| |
| default: |
| unexpected_statement (st); |
| break; |
| } |
| |
| continue; |
| |
| error: |
| error_flag = true; |
| reject_statement (); |
| } |
| |
| pop_state (); |
| gcc_assert (gfc_current_state () == COMP_DERIVED); |
| |
| return error_flag; |
| } |
| |
| |
| /* Set attributes for the parent symbol based on the attributes of a component |
| and raise errors if conflicting attributes are found for the component. */ |
| |
| static void |
| check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp, |
| gfc_component **eventp) |
| { |
| bool coarray, lock_type, event_type, allocatable, pointer; |
| coarray = lock_type = event_type = allocatable = pointer = false; |
| gfc_component *lock_comp = NULL, *event_comp = NULL; |
| |
| if (lockp) lock_comp = *lockp; |
| if (eventp) event_comp = *eventp; |
| |
| /* Look for allocatable components. */ |
| if (c->attr.allocatable |
| || (c->ts.type == BT_CLASS && c->attr.class_ok |
| && CLASS_DATA (c)->attr.allocatable) |
| || (c->ts.type == BT_DERIVED && !c->attr.pointer |
| && c->ts.u.derived->attr.alloc_comp)) |
| { |
| allocatable = true; |
| sym->attr.alloc_comp = 1; |
| } |
| |
| /* Look for pointer components. */ |
| if (c->attr.pointer |
| || (c->ts.type == BT_CLASS && c->attr.class_ok |
| && CLASS_DATA (c)->attr.class_pointer) |
| || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) |
| { |
| pointer = true; |
| sym->attr.pointer_comp = 1; |
| } |
| |
| /* Look for procedure pointer components. */ |
| if (c->attr.proc_pointer |
| || (c->ts.type == BT_DERIVED |
| && c->ts.u.derived->attr.proc_pointer_comp)) |
| sym->attr.proc_pointer_comp = 1; |
| |
| /* Looking for coarray components. */ |
| if (c->attr.codimension |
| || (c->ts.type == BT_CLASS && c->attr.class_ok |
| && CLASS_DATA (c)->attr.codimension)) |
| { |
| coarray = true; |
| sym->attr.coarray_comp = 1; |
| } |
| |
| if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp |
| && !c->attr.pointer) |
| { |
| coarray = true; |
| sym->attr.coarray_comp = 1; |
| } |
| |
| /* Looking for lock_type components. */ |
| if ((c->ts.type == BT_DERIVED |
| && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV |
| && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) |
| || (c->ts.type == BT_CLASS && c->attr.class_ok |
| && CLASS_DATA (c)->ts.u.derived->from_intmod |
| == INTMOD_ISO_FORTRAN_ENV |
| && CLASS_DATA (c)->ts.u.derived->intmod_sym_id |
| == ISOFORTRAN_LOCK_TYPE) |
| || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp |
| && !allocatable && !pointer)) |
| { |
| lock_type = 1; |
| lock_comp = c; |
| sym->attr.lock_comp = 1; |
| } |
| |
| /* Looking for event_type components. */ |
| if ((c->ts.type == BT_DERIVED |
| && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV |
| && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) |
| || (c->ts.type == BT_CLASS && c->attr.class_ok |
| && CLASS_DATA (c)->ts.u.derived->from_intmod |
| == INTMOD_ISO_FORTRAN_ENV |
| && CLASS_DATA (c)->ts.u.derived->intmod_sym_id |
| == ISOFORTRAN_EVENT_TYPE) |
| || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp |
| && !allocatable && !pointer)) |
| { |
| event_type = 1; |
| event_comp = c; |
| sym->attr.event_comp = 1; |
| } |
| |
| /* Check for F2008, C1302 - and recall that pointers may not be coarrays |
| (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7), |
| unless there are nondirect [allocatable or pointer] components |
| involved (cf. 1.3.33.1 and 1.3.33.3). */ |
| |
| if (pointer && !coarray && lock_type) |
| gfc_error ("Component %s at %L of type LOCK_TYPE must have a " |
| "codimension or be a subcomponent of a coarray, " |
| "which is not possible as the component has the " |
| "pointer attribute", c->name, &c->loc); |
| else if (pointer && !coarray && c->ts.type == BT_DERIVED |
| && c->ts.u.derived->attr.lock_comp) |
| gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " |
| "of type LOCK_TYPE, which must have a codimension or be a " |
| "subcomponent of a coarray", c->name, &c->loc); |
| |
| if (lock_type && allocatable && !coarray) |
| gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have " |
| "a codimension", c->name, &c->loc); |
| else if (lock_type && allocatable && c->ts.type == BT_DERIVED |
| && c->ts.u.derived->attr.lock_comp) |
| gfc_error ("Allocatable component %s at %L must have a codimension as " |
| "it has a noncoarray subcomponent of type LOCK_TYPE", |
| c->name, &c->loc); |
| |
| if (sym->attr.coarray_comp && !coarray && lock_type) |
| gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " |
| "subcomponent of type LOCK_TYPE must have a codimension or " |
| "be a subcomponent of a coarray. (Variables of type %s may " |
| "not have a codimension as already a coarray " |
| "subcomponent exists)", c->name, &c->loc, sym->name); |
| |
| if (sym->attr.lock_comp && coarray && !lock_type) |
| gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with " |
| "subcomponent of type LOCK_TYPE must have a codimension or " |
| "be a subcomponent of a coarray. (Variables of type %s may " |
| "not have a codimension as %s at %L has a codimension or a " |
| "coarray subcomponent)", lock_comp->name, &lock_comp->loc, |
| sym->name, c->name, &c->loc); |
| |
| /* Similarly for EVENT TYPE. */ |
| |
| if (pointer && !coarray && event_type) |
| gfc_error ("Component %s at %L of type EVENT_TYPE must have a " |
| "codimension or be a subcomponent of a coarray, " |
| "which is not possible as the component has the " |
| "pointer attribute", c->name, &c->loc); |
| else if (pointer && !coarray && c->ts.type == BT_DERIVED |
| && c->ts.u.derived->attr.event_comp) |
| gfc_error ("Pointer component %s at %L has a noncoarray subcomponent " |
| "of type EVENT_TYPE, which must have a codimension or be a " |
| "subcomponent of a coarray", c->name, &c->loc); |
| |
| if (event_type && allocatable && !coarray) |
| gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have " |
| "a codimension", c->name, &c->loc); |
| else if (event_type && allocatable && c->ts.type == BT_DERIVED |
| && c->ts.u.derived->attr.event_comp) |
| gfc_error ("Allocatable component %s at %L must have a codimension as " |
| "it has a noncoarray subcomponent of type EVENT_TYPE", |
| c->name, &c->loc); |
| |
| if (sym->attr.coarray_comp && !coarray && event_type) |
| gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " |
| "subcomponent of type EVENT_TYPE must have a codimension or " |
| "be a subcomponent of a coarray. (Variables of type %s may " |
| "not have a codimension as already a coarray " |
| "subcomponent exists)", c->name, &c->loc, sym->name); |
| |
| if (sym->attr.event_comp && coarray && !event_type) |
| gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with " |
| "subcomponent of type EVENT_TYPE must have a codimension or " |
| "be a subcomponent of a coarray. (Variables of type %s may " |
| "not have a codimension as %s at %L has a codimension or a " |
| "coarray subcomponent)", event_comp->name, &event_comp->loc, |
| sym->name, c->name, &c->loc); |
| |
| /* Look for private components. */ |
| if (sym->component_access == ACCESS_PRIVATE |
| || c->attr.access == ACCESS_PRIVATE |
| || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) |
| sym->attr.private_comp = 1; |
| |
| if (lockp) *lockp = lock_comp; |
| if (eventp) *eventp = event_comp; |
| } |
| |
| |
| static void parse_struct_map (gfc_statement); |
| |
| /* Parse a union component definition within a structure definition. */ |
| |
| static void |
| parse_union (void) |
| { |
| int compiling; |
| gfc_statement st; |
| gfc_state_data s; |
| gfc_component *c, *lock_comp = NULL, *event_comp = NULL; |
| gfc_symbol *un; |
| |
| accept_statement(ST_UNION); |
| push_state (&s, COMP_UNION, gfc_new_block); |
| un = gfc_new_block; |
| |
| compiling = 1; |
| |
| while (compiling) |
| { |
| st = next_statement (); |
| /* Only MAP declarations valid within a union. */ |
| switch (st) |
| { |
| case ST_NONE: |
| unexpected_eof (); |
| |
| case ST_MAP: |
| accept_statement (ST_MAP); |
| parse_struct_map (ST_MAP); |
| /* Add a component to the union for each map. */ |
| if (!gfc_add_component (un, gfc_new_block->name, &c)) |
| { |
| gfc_internal_error ("failed to create map component '%s'", |
| gfc_new_block->name); |
| reject_statement (); |
| return; |
| } |
| c->ts.type = BT_DERIVED; |
| c->ts.u.derived = gfc_new_block; |
| /* Normally components get their initialization expressions when they |
| are created in decl.c (build_struct) so we can look through the |
| flat component list for initializers during resolution. Unions and |
| maps create components along with their type definitions so we |
| have to generate initializers here. */ |
| c->initializer = gfc_default_initializer (&c->ts); |
| break; |
| |
| case ST_END_UNION: |
| compiling = 0; |
| accept_statement (ST_END_UNION); |
| break; |
| |
| default: |
| unexpected_statement (st); |
| break; |
| } |
| } |
| |
| for (c = un->components; c; c = c->next) |
| check_component (un, c, &lock_comp, &event_comp); |
| |
| /* Add the union as a component in its parent structure. */ |
| pop_state (); |
| if (!gfc_add_component (gfc_current_block (), un->name, &c)) |
| { |
| gfc_internal_error ("failed to create union component '%s'", un->name); |
| reject_statement (); |
| return; |
| } |
| c->ts.type = BT_UNION; |
| c->ts.u.derived = un; |
| c->initializer = gfc_default_initializer (&c->ts); |
| |
| un->attr.zero_comp = un->components == NULL; |
| } |
| |
| |
| /* Parse a STRUCTURE or MAP. */ |
| |
| static void |
| parse_struct_map (gfc_statement block) |
| { |
| int compiling_type; |
| gfc_statement st; |
| gfc_state_data s; |
| gfc_symbol *sym; |
| gfc_component *c, *lock_comp = NULL, *event_comp = NULL; |
| gfc_compile_state comp; |
| gfc_statement ends; |
| |
| if (block == ST_STRUCTURE_DECL) |
| { |
| comp = COMP_STRUCTURE; |
| ends = ST_END_STRUCTURE; |
| } |
| else |
| { |
| gcc_assert (block == ST_MAP); |
| comp = COMP_MAP; |
| ends = ST_END_MAP; |
| } |
| |
| accept_statement(block); |
| push_state (&s, comp, gfc_new_block); |
| |
| gfc_new_block->component_access = ACCESS_PUBLIC; |
| compiling_type = 1; |
| |
| while (compiling_type) |
| { |
| st = next_statement (); |
| switch (st) |
| { |
| case ST_NONE: |
| unexpected_eof (); |
| |
| /* Nested structure declarations will be captured as ST_DATA_DECL. */ |
| case ST_STRUCTURE_DECL: |
| /* Let a more specific error make it to decode_statement(). */ |
| if (gfc_error_check () == 0) |
| gfc_error ("Syntax error in nested structure declaration at %C"); |
| reject_statement (); |
| /* Skip the rest of this statement. */ |
| gfc_error_recovery (); |
| break; |
| |
| case ST_UNION: |
| accept_statement (ST_UNION); |
| parse_union (); |
| break; |
| |
| case ST_DATA_DECL: |
| /* The data declaration was a nested/ad-hoc STRUCTURE field. */ |
| accept_statement (ST_DATA_DECL); |
| if (gfc_new_block && gfc_new_block != gfc_current_block () |
| && gfc_new_block->attr.flavor == FL_STRUCT) |
| parse_struct_map (ST_STRUCTURE_DECL); |
| break; |
| |
| case ST_END_STRUCTURE: |
| case ST_END_MAP: |
| if (st == ends) |
| { |
| accept_statement (st); |
| compiling_type = 0; |
| } |
| else |
| unexpected_statement (st); |
| break; |
| |
| default: |
| unexpected_statement (st); |
| break; |
| } |
| } |
| |
| /* Validate each component. */ |
| sym = gfc_current_block (); |
| for (c = sym->components; c; c = c->next) |
| check_component (sym, c, &lock_comp, &event_comp); |
| |
| sym->attr.zero_comp = (sym->components == NULL); |
| |
| /* Allow parse_union to find this structure to add to its list of maps. */ |
| if (block == ST_MAP) |
| gfc_new_block = gfc_current_block (); |
| |
| pop_state (); |
| } |
| |
| |
| /* Parse a derived type. */ |
| |
| static void |
| parse_derived (void) |
| { |
| int compiling_type, seen_private, seen_sequence, seen_component; |
| gfc_statement st; |
| gfc_state_data s; |
| gfc_symbol *sym; |
| gfc_component *c, *lock_comp = NULL, *event_comp = NULL; |
| |
| accept_statement (ST_DERIVED_DECL); |
| push_state (&s, COMP_DERIVED, gfc_new_block); |
| |
| gfc_new_block->component_access = ACCESS_PUBLIC; |
|