diff options
Diffstat (limited to 'gcc/fortran/parse.c')
| -rw-r--r-- | gcc/fortran/parse.c | 727 |
1 files changed, 514 insertions, 213 deletions
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7bce47fef0..0aa736c708 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -256,6 +256,7 @@ decode_specification_statement (void) case 's': match ("save", gfc_match_save, ST_ATTR_DECL); + match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL); break; case 't': @@ -507,6 +508,7 @@ decode_statement (void) 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; @@ -542,6 +544,7 @@ decode_statement (void) 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); @@ -558,6 +561,7 @@ decode_statement (void) break; case 'u': + match ("union", gfc_match_union, ST_UNION); match ("unlock", gfc_match_unlock, ST_UNLOCK); break; @@ -585,21 +589,12 @@ decode_statement (void) return ST_NONE; } -/* Like match, but set a flag simd_matched if keyword matched. */ -#define matchs(keyword, subr, st) \ - do { \ - if (match_word_omp_simd (keyword, subr, &old_locus, \ - &simd_matched) == MATCH_YES) \ - return st; \ - else \ - undo_new_statement (); \ - } while (0); - -/* Like match, but don't match anything if not -fopenmp. */ -#define matcho(keyword, subr, st) \ +/* Like match and if spec_only, goto do_spec_only without actually + matching. */ +#define matcha(keyword, subr, st) \ do { \ - if (!flag_openmp) \ - ; \ + if (spec_only && gfc_match (keyword) == MATCH_YES) \ + goto do_spec_only; \ else if (match_word (keyword, subr, &old_locus) \ == MATCH_YES) \ return st; \ @@ -612,6 +607,7 @@ decode_oacc_directive (void) { locus old_locus; char c; + bool spec_only = false; gfc_enforce_clean_symbol_state (); @@ -626,6 +622,10 @@ decode_oacc_directive (void) 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; @@ -639,49 +639,52 @@ decode_oacc_directive (void) switch (c) { case 'a': - match ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); + matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); break; case 'c': - match ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); + matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE); break; case 'd': - match ("data", gfc_match_oacc_data, ST_OACC_DATA); + matcha ("data", gfc_match_oacc_data, ST_OACC_DATA); match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE); break; case 'e': - match ("end atomic", gfc_match_omp_eos, ST_OACC_END_ATOMIC); - match ("end data", gfc_match_omp_eos, ST_OACC_END_DATA); - match ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA); - match ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LOOP); - match ("end kernels", gfc_match_omp_eos, ST_OACC_END_KERNELS); - match ("end loop", gfc_match_omp_eos, ST_OACC_END_LOOP); - match ("end parallel loop", gfc_match_omp_eos, ST_OACC_END_PARALLEL_LOOP); - match ("end parallel", gfc_match_omp_eos, ST_OACC_END_PARALLEL); - match ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA); - match ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA); + 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': - match ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); + matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA); break; case 'p': - match ("parallel loop", gfc_match_oacc_parallel_loop, ST_OACC_PARALLEL_LOOP); - match ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); + matcha ("parallel loop", gfc_match_oacc_parallel_loop, + ST_OACC_PARALLEL_LOOP); + matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL); break; case 'k': - match ("kernels loop", gfc_match_oacc_kernels_loop, ST_OACC_KERNELS_LOOP); - match ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); + matcha ("kernels loop", gfc_match_oacc_kernels_loop, + ST_OACC_KERNELS_LOOP); + matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS); break; case 'l': - match ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); + matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); break; case 'r': match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); break; case 'u': - match ("update", gfc_match_oacc_update, ST_OACC_UPDATE); + matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE); break; case 'w': - match ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); + matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT); break; } @@ -696,14 +699,72 @@ decode_oacc_directive (void) 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) \ + return st; \ + 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) \ + return st; \ + 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) \ + return st; \ + 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) \ + return st; \ + 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_enforce_clean_symbol_state (); @@ -718,6 +779,10 @@ decode_omp_directive (void) 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; @@ -746,12 +811,12 @@ decode_omp_directive (void) matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); break; case 'd': - matchs ("declare reduction", gfc_match_omp_declare_reduction, - ST_OMP_DECLARE_REDUCTION); - matchs ("declare simd", gfc_match_omp_declare_simd, - ST_OMP_DECLARE_SIMD); - matcho ("declare target", gfc_match_omp_declare_target, - ST_OMP_DECLARE_TARGET); + matchds ("declare reduction", gfc_match_omp_declare_reduction, + ST_OMP_DECLARE_REDUCTION); + matchds ("declare simd", gfc_match_omp_declare_simd, + ST_OMP_DECLARE_SIMD); + matchdo ("declare target", gfc_match_omp_declare_target, + ST_OMP_DECLARE_TARGET); matchs ("distribute parallel do simd", gfc_match_omp_distribute_parallel_do_simd, ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD); @@ -871,8 +936,8 @@ decode_omp_directive (void) matcho ("teams distribute", gfc_match_omp_teams_distribute, ST_OMP_TEAMS_DISTRIBUTE); matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS); - matcho ("threadprivate", gfc_match_omp_threadprivate, - ST_OMP_THREADPRIVATE); + matchdo ("threadprivate", gfc_match_omp_threadprivate, + ST_OMP_THREADPRIVATE); break; case 'w': matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); @@ -895,6 +960,13 @@ decode_omp_directive (void) 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; } static gfc_statement @@ -1315,10 +1387,13 @@ next_statement (void) gfc_buffer_error (false); - if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL) + if (st == ST_GET_FCN_CHARACTERISTICS) { - gfc_free_st_label (gfc_statement_label); - gfc_statement_label = NULL; + if (gfc_statement_label != NULL) + { + gfc_free_st_label (gfc_statement_label); + gfc_statement_label = NULL; + } gfc_current_locus = old_locus; } @@ -1386,9 +1461,13 @@ next_statement (void) #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_OMP_THREADPRIVATE: \ - case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \ - case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + 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(). */ @@ -1642,6 +1721,15 @@ gfc_ascii_statement (gfc_statement st) 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; @@ -1711,6 +1799,15 @@ gfc_ascii_statement (gfc_statement st) 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; @@ -2457,6 +2554,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) case ST_PUBLIC: case ST_PRIVATE: + case ST_STRUCTURE_DECL: case ST_DERIVED_DECL: case_decl: if (p->state >= ORDER_EXEC) @@ -2465,6 +2563,14 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) 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) @@ -2646,6 +2752,358 @@ error: } +/* 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 @@ -2762,170 +3220,7 @@ endType: */ sym = gfc_current_block (); for (c = sym->components; c; c = c->next) - { - bool coarray, lock_type, event_type, allocatable, pointer; - coarray = lock_type = event_type = allocatable = pointer = false; - - /* 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; - } + check_component (sym, c, &lock_comp, &event_comp); if (!seen_component) sym->attr.zero_comp = 1; @@ -3348,8 +3643,10 @@ loop: case ST_PARAMETER: case ST_PUBLIC: case ST_PRIVATE: + case ST_STRUCTURE_DECL: case ST_DERIVED_DECL: case_decl: + case_omp_decl: declSt: if (!verify_st_order (&ss, st, false)) { @@ -3364,6 +3661,10 @@ declSt: parse_interface (); break; + case ST_STRUCTURE_DECL: + parse_struct_map (ST_STRUCTURE_DECL); + break; + case ST_DERIVED_DECL: parse_derived (); break; |