Please see the original thread https://gcc.gnu.org/ml/fortran/2016-03/msg00002.html.
I have to send the patches separately, as together they cause me to be blocked for spamming. This is patch 3: --- Fritz Reese
From 93e96b8a9e62c0413e6d9d33c01fa7825ecd9ee4 Mon Sep 17 00:00:00 2001 From: Fritz O. Reese <fritzore...@gmail.com> Date: Thu, 13 Nov 2014 14:41:04 -0500 Subject: [PATCH 3/4] 2014-11-13 Fritz Reese <fritzore...@gmail.com> gcc/fortran/ * parse.c (check_component): New function. (parse_derived): Move loop code to check_component. --- gcc/fortran/parse.c | 343 +++++++++++++++++++++++++++------------------------ 1 files changed, 179 insertions(+), 164 deletions(-) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7bce47f..1374c13 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2646,6 +2646,184 @@ 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, *event_comp; + + lock_comp = *lockp; + 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; + + *lockp = lock_comp; + *eventp = event_comp; +} + /* Parse a derived type. */ static void @@ -2762,170 +2940,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; -- 1.7.1