diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 10 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 20 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 168 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 1 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/lto/pr45586_0.f90 | 29 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_proc_20.f90 | 68 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_proc_21.f90 | 27 |
8 files changed, 327 insertions, 0 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 31ed636..c0b8d5a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2011-02-18 Michael Matz <matz@suse.de> + + PR fortran/45586 + * gfortran.h (struct gfc_component): Add norestrict_decl member. + * trans.h (struct lang_type): Add nonrestricted_type member. + * trans-expr.c (gfc_conv_component_ref): Search fields with correct + parent type. + * trans-types.c (mirror_fields, gfc_nonrestricted_type): New. + (gfc_sym_type): Use it. + 2011-02-18 Janus Weil <janus@gcc.gnu.org> PR fortran/47768 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ae12534..b64fa20 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -934,6 +934,10 @@ typedef struct gfc_component gfc_array_spec *as; tree backend_decl; + /* Used to cache a FIELD_DECL matching this same component + but applied to a different backend containing type that was + generated by gfc_nonrestricted_type. */ + tree norestrict_decl; locus loc; struct gfc_expr *initializer; struct gfc_component *next; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b7d7ed9..3cf8df5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -504,6 +504,26 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) field = c->backend_decl; gcc_assert (TREE_CODE (field) == FIELD_DECL); decl = se->expr; + + /* Components can correspond to fields of different containing + types, as components are created without context, whereas + a concrete use of a component has the type of decl as context. + So, if the type doesn't match, we search the corresponding + FIELD_DECL in the parent type. To not waste too much time + we cache this result in norestrict_decl. */ + + if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl)) + { + tree f2 = c->norestrict_decl; + if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl)) + for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2)) + if (TREE_CODE (f2) == FIELD_DECL + && DECL_NAME (f2) == DECL_NAME (field)) + break; + gcc_assert (f2); + c->norestrict_decl = f2; + field = f2; + } tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7c29974..0626a87 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1746,6 +1746,171 @@ gfc_build_pointer_type (gfc_symbol * sym, tree type) else return build_pointer_type (type); } + +static tree gfc_nonrestricted_type (tree t); +/* Given two record or union type nodes TO and FROM, ensure + that all fields in FROM have a corresponding field in TO, + their type being nonrestrict variants. This accepts a TO + node that already has a prefix of the fields in FROM. */ +static void +mirror_fields (tree to, tree from) +{ + tree fto, ffrom; + tree *chain; + + /* Forward to the end of TOs fields. */ + fto = TYPE_FIELDS (to); + ffrom = TYPE_FIELDS (from); + chain = &TYPE_FIELDS (to); + while (fto) + { + gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom)); + chain = &DECL_CHAIN (fto); + fto = DECL_CHAIN (fto); + ffrom = DECL_CHAIN (ffrom); + } + + /* Now add all fields remaining in FROM (starting with ffrom). */ + for (; ffrom; ffrom = DECL_CHAIN (ffrom)) + { + tree newfield = copy_node (ffrom); + DECL_CONTEXT (newfield) = to; + /* The store to DECL_CHAIN might seem redundant with the + stores to *chain, but not clearing it here would mean + leaving a chain into the old fields. If ever + our called functions would look at them confusion + will arise. */ + DECL_CHAIN (newfield) = NULL_TREE; + *chain = newfield; + chain = &DECL_CHAIN (newfield); + + if (TREE_CODE (ffrom) == FIELD_DECL) + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom)); + TREE_TYPE (newfield) = elemtype; + } + } + *chain = NULL_TREE; +} + +/* Given a type T, returns a different type of the same structure, + except that all types it refers to (recursively) are always + non-restrict qualified types. */ +static tree +gfc_nonrestricted_type (tree t) +{ + tree ret = t; + + /* If the type isn't layed out yet, don't copy it. If something + needs it for real it should wait until the type got finished. */ + if (!TYPE_SIZE (t)) + return t; + + if (!TYPE_LANG_SPECIFIC (t)) + TYPE_LANG_SPECIFIC (t) + = ggc_alloc_cleared_lang_type (sizeof (struct lang_type)); + /* If we're dealing with this very node already further up + the call chain (recursion via pointers and struct members) + we haven't yet determined if we really need a new type node. + Assume we don't, return T itself. */ + if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node) + return t; + + /* If we have calculated this all already, just return it. */ + if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type) + return TYPE_LANG_SPECIFIC (t)->nonrestricted_type; + + /* Mark this type. */ + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node; + + switch (TREE_CODE (t)) + { + default: + break; + + case POINTER_TYPE: + case REFERENCE_TYPE: + { + tree totype = gfc_nonrestricted_type (TREE_TYPE (t)); + if (totype == TREE_TYPE (t)) + ret = t; + else if (TREE_CODE (t) == POINTER_TYPE) + ret = build_pointer_type (totype); + else + ret = build_reference_type (totype); + ret = build_qualified_type (ret, + TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT); + } + break; + + case ARRAY_TYPE: + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t)); + if (elemtype == TREE_TYPE (t)) + ret = t; + else + { + ret = build_variant_type_copy (t); + TREE_TYPE (ret) = elemtype; + if (TYPE_LANG_SPECIFIC (t) + && GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) + { + tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t); + dataptr_type = gfc_nonrestricted_type (dataptr_type); + if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) + { + TYPE_LANG_SPECIFIC (ret) + = ggc_alloc_cleared_lang_type (sizeof (struct + lang_type)); + *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t); + GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type; + } + } + } + } + break; + + case RECORD_TYPE: + case UNION_TYPE: + case QUAL_UNION_TYPE: + { + tree field; + /* First determine if we need a new type at all. + Careful, the two calls to gfc_nonrestricted_type per field + might return different values. That happens exactly when + one of the fields reaches back to this very record type + (via pointers). The first calls will assume that we don't + need to copy T (see the error_mark_node marking). If there + are any reasons for copying T apart from having to copy T, + we'll indeed copy it, and the second calls to + gfc_nonrestricted_type will use that new node if they + reach back to T. */ + for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field)) + if (TREE_CODE (field) == FIELD_DECL) + { + tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field)); + if (elemtype != TREE_TYPE (field)) + break; + } + if (!field) + break; + ret = build_variant_type_copy (t); + TYPE_FIELDS (ret) = NULL_TREE; + + /* Here we make sure that as soon as we know we have to copy + T, that also fields reaching back to us will use the new + copy. It's okay if that copy still contains the old fields, + we won't look at them. */ + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; + mirror_fields (ret, t); + } + break; + } + + TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; + return ret; +} + /* Return the type for a symbol. Special handling is required for character types to get the correct level of indirection. @@ -1796,6 +1961,9 @@ gfc_sym_type (gfc_symbol * sym) restricted = !sym->attr.target && !sym->attr.pointer && !sym->attr.proc_pointer && !sym->attr.cray_pointee; + if (!restricted) + type = gfc_nonrestricted_type (type); + if (sym->attr.dimension) { if (gfc_is_nodesc_array (sym)) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 26ac003..9695c5a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -700,6 +700,7 @@ struct GTY((variable_size)) lang_type { tree dataptr_type; tree span; tree base_decl[2]; + tree nonrestricted_type; }; struct GTY((variable_size)) lang_decl { diff --git a/gcc/testsuite/gfortran.dg/lto/pr45586_0.f90 b/gcc/testsuite/gfortran.dg/lto/pr45586_0.f90 new file mode 100644 index 0000000..84f3633 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/lto/pr45586_0.f90 @@ -0,0 +1,29 @@ +! { dg-lto-do link } + MODULE M1 + INTEGER, PARAMETER :: dp=8 + TYPE realspace_grid_type + + REAL(KIND=dp), DIMENSION ( :, :, : ), ALLOCATABLE :: r + + END TYPE realspace_grid_type + END MODULE + + MODULE M2 + USE m1 + CONTAINS + SUBROUTINE S1(x) + TYPE(realspace_grid_type), POINTER :: x + REAL(dp), DIMENSION(:, :, :), POINTER :: y + y=>x%r + y=0 + + END SUBROUTINE + END MODULE + + USE M2 + TYPE(realspace_grid_type), POINTER :: x + ALLOCATE(x) + ALLOCATE(x%r(10,10,10)) + CALL S1(x) + write(6,*) x%r + END diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 new file mode 100644 index 0000000..4fee2f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_20.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! TODO: make runtime testcase once bug is fixed +! +! PR fortran/47455 +! +! Based on an example by Thomas Henlich +! + +module class_t + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type :: t + type(tx), pointer :: x + type(tx) :: y + contains + procedure :: calc + procedure :: find_x + procedure :: find_y + end type t +contains + subroutine calc(this) + class(t), target :: this + type(tx), target :: that + that%i = [1,2] + this%x => this%find_x(that, .true.) + if (associated (this%x)) call abort() + this%x => this%find_x(that, .false.) + if(any (this%x%i /= [5, 7])) call abort() + if (.not.associated (this%x,that)) call abort() + allocate(this%x) + if (associated (this%x,that)) call abort() + if (allocated(this%x%i)) call abort() + this%x = this%find_x(that, .false.) + that%i = [3,4] + if(any (this%x%i /= [5, 7])) call abort() ! FAILS + + if (allocated (this%y%i)) call abort() + this%y = this%find_y() ! FAILS + if (.not.allocated (this%y%i)) call abort() + if(any (this%y%i /= [6, 8])) call abort() + end subroutine calc + function find_x(this, that, l_null) + class(t), intent(in) :: this + type(tx), target :: that + type(tx), pointer :: find_x + logical :: l_null + if (l_null) then + find_x => null() + else + find_x => that + that%i = [5, 7] + end if + end function find_x + function find_y(this) result(res) + class(t), intent(in) :: this + type(tx), allocatable :: res + allocate(res) + res%i = [6, 8] + end function find_y +end module class_t + +use class_t +type(t) :: x +call x%calc() +end + +! { dg-final { cleanup-modules "class_t" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_21.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_21.f90 new file mode 100644 index 0000000..6c16d46 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_21.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/47455 +! +module class_t + type :: tx + integer, dimension(:), allocatable :: i + end type tx + type :: t + type(tx), pointer :: x + contains + procedure :: calc + procedure :: find_x + end type t +contains + subroutine calc(this) + class(t), target :: this + this%x = this%find_x() + end subroutine calc + function find_x(this) + class(t), intent(in) :: this + type(tx), pointer :: find_x + find_x => null() + end function find_x +end module class_t + +! { dg-final { cleanup-modules "class_t" } } |