diff options
Diffstat (limited to 'gcc/fortran/parse.c')
| -rw-r--r-- | gcc/fortran/parse.c | 545 |
1 files changed, 381 insertions, 164 deletions
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7bce47fef0a..dd7aa6a4e13 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; @@ -1642,6 +1646,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 +1724,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 +2479,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) @@ -2646,6 +2669,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 +3137,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,6 +3560,7 @@ loop: case ST_PARAMETER: case ST_PUBLIC: case ST_PRIVATE: + case ST_STRUCTURE_DECL: case ST_DERIVED_DECL: case_decl: declSt: @@ -3364,6 +3577,10 @@ declSt: parse_interface (); break; + case ST_STRUCTURE_DECL: + parse_struct_map (ST_STRUCTURE_DECL); + break; + case ST_DERIVED_DECL: parse_derived (); break; |