[Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
Paul Richard Thomas
paul.richard.thomas@gmail.com
Sun Jul 9 18:43:00 GMT 2017
Hi Thomas, Hi All,
Please find attached what I believe is the final version of the patch.
The problem concerning temporaries being generated in lieu of the
descriptor being passed directly - see pointer_array_7.f90 and the
change to subref_array_4.f90. This latter necessitated a thread on clf
to get right. Thanks are due to Thomas for initiating it.
I took the opportunity of the delay, while the bounds issue was being
discussed on clf, to fix class pointer arrays. They now function
correctly, as evidenced by pointer_array_8.f90.
A possible final tweak - as asked before, should I bump up the module
version number? My inclination is to say that we should.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
Paul
2017-07-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
PR fortran/40737
PR fortran/55763
PR fortran/57019
PR fortran/57116
* expr.c (is_subref_array): Add class pointer array dummies
to the list of expressions that return true.
* trans-array.c: Add SPAN_FIELD and update indices for
subsequent fields.
(gfc_conv_descriptor_span, gfc_conv_descriptor_span_get,
gfc_conv_descriptor_span_set, is_pointer_array,
get_array_span): New functions.
(gfc_get_descriptor_offsets_for_info): New function to preserve
API for access to descriptor fields for trans-types.c.
(gfc_conv_scalarized_array_ref): If the expression is a subref
array, make sure that info->descriptor is a descriptor type.
Otherwise, if info->descriptor is a pointer array, set 'decl'
and fix it if it is a component reference.
(build_array_ref): Simplify handling of class array refs by
passing the vptr to gfc_build_array_ref rather than generating
the pointer arithmetic in this function.
(gfc_conv_array_ref): As in gfc_conv_scalarized_array_ref, set
'decl'.
(gfc_array_allocate): Set the span field if this is a pointer
array. Use the expr3 element size if it is available, so that
the dynamic type element size is used.
(gfc_conv_expr_descriptor): Set the span field for pointer
assignments.
* trans-array.h: Prototypes for gfc_conv_descriptor_span_get
gfc_conv_descriptor_span_set and
gfc_get_descriptor_offsets_for_info added.
trans-decl.c (gfc_get_symbol_decl): If a non-class pointer
array, mark the declaration as a GFC_DECL_PTR_ARRAY_P. Remove
the setting of GFC_DECL_SPAN.
(gfc_trans_deferred_vars): Set the span field to zero in thge
originating scope.
* trans-expr.c (gfc_conv_procedure_call): Do not use copy-in/
copy-out to pass subref expressions to a pointer dummy.
(gfc_trans_pointer_assignment): Remove code for setting of
GFC_DECL_SPAN. Set the 'span' field for non-class pointers to
class function results. Likewise for rank remap.
* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Pick up the
'token' offset from the field decl in the descriptor.
(conv_isocbinding_subroutine): Set the 'span' field.
* trans-io.c (gfc_trans_transfer): Always scalarize pointer
array io.
* trans-stmt.c (trans_associate_var): Set the 'span' field.
* trans-types.c (gfc_get_array_descriptor_base): Add the 'span'
field to the array descriptor.
(gfc_get_derived_type): Pointer array components are marked as
GFC_DECL_PTR_ARRAY_P.
(gfc_get_array_descr_info): Replaced API breaking code for
descriptor offset calling gfc_get_descriptor_offsets_for_info.
* trans.c (get_array_span): New function.
(gfc_build_array_ref): Simplify by calling get_array_span and
obtain 'span' if 'decl' or 'vptr' present.
* trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
as GFC_DECL_PTR_ARRAY_P.
2017-07-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
* gfortran.dg/assumed_type_2.f90: Adjust some of the tree dump
checks.
* gfortran.dg/no_arg_check_2.f90: Likewise.
* gfortran.dg/pointer_array_1.f90: New test.
* gfortran.dg/pointer_array_2.f90: New test.
* gfortran.dg/pointer_array_7.f90: New test.
* gfortran.dg/pointer_array_8.f90: New test.
* gfortran.dg/pointer_array_component_1.f90: New test.
* gfortran.dg/pointer_array_component_2.f90: New test.
* gfortran.dg/goacc/kernels-alias-4.f95: Bump up both tree scan
counts by 1.
* gfortran.dg/subref_array_pointer_4.f90: Use the passed lower
bound for 'Q' to provide an offset for array element access.
PR fortran/40737
* gfortran.dg/pointer_array_3.f90: New test.
PR fortran/57116
* gfortran.dg/pointer_array_4.f90: New test.
PR fortran/55763
* gfortran.dg/pointer_array_5.f90: New test.
PR fortran/57019
* gfortran.dg/pointer_array_6.f90: New test.
2017-07-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
* libgfortran/libgfortran.h: Add span field to descriptor.
On 4 July 2017 at 22:03, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Paul,
>
> first, this patch looks really good - it certainly fixes a lot of the
> ICEs.
>
> I have a few points (a part already mentioned in private mail).
>
> Consider the test case:
>
> module x
> use iso_c_binding
> implicit none
> type foo
> complex :: c
> integer :: i
> end type foo
> contains
> subroutine printit(c)
> complex, pointer, dimension(:) :: c
> integer :: i
> integer(kind=8) :: a
> a = transfer(c_loc(c(1)),a)
> print '(A,Z16)',"Adrress of first element is ", a
> end subroutine printit
>
> subroutine p2(c)
> complex, dimension(:), target :: c
> integer :: i
> integer(kind=8) :: a
> a = transfer(c_loc(c(1)),a)
> print '(A,Z16)',"Adrress of first element is ", a
> end subroutine p2
>
> end module x
>
> program main
> use x
> use iso_c_binding
> implicit none
> type(foo), dimension(5), target :: a
> integer :: i
> complex, dimension(:), pointer :: pc
> complex, dimension(4), target :: v
> integer(kind=8) :: s1, s2
> a%i = 0
> do i=1,5
> a(i)%c = cmplx(i**2,i)
> end do
> pc => a%c
> print *,"Pointer to complex passed to pointer argument:"
> call printit(pc)
> print *,"Pointer to complex passed to array argument"
> call p2(pc)
> s1 = transfer(c_loc(a(1)),s1)
> print '(A,Z16,/)',"Main program: Address of first element: ", s1
>
> pc => v
> print *,"Pointer to complex passed to pointer argument:"
> call printit(pc)
> print *,"Complex array passed to array argument"
> call p2(v)
> s1 = transfer(c_loc(v(1)),s1)
> print '(A,Z16)',"Address of first element: ", s1
> end program main
>
> This yields:
>
> Pointer to complex passed to pointer argument:
> Adrress of first element is 10021C90FF0
> Pointer to complex passed to array argument
> Adrress of first element is 10021C90FF0
> Main program: Address of first element: 3FFFCEC599A4
>
> Pointer to complex passed to pointer argument:
> Adrress of first element is 10021C90FF0
> Complex array passed to array argument
> Adrress of first element is 3FFFCEC59A20
> Address of first element: 3FFFCEC59A20
>
> It appears that a temporary is created when passing
> a pointer array to a pointer array dummy argument.
> I think this would be wrong code, because the
> subroutine could stash away the pointer and later
> access data through it.
>
> The same seems to happen when passing a pointer to
> a normal argument - a temporary copy appears to be made.
>
> While this code is correct, I am wodering if it
> is intentional. Is the span field in the array
> descriptor used in the called subroutine?
>
> Regards
>
> Thomas
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
-------------- next part --------------
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 249865)
--- gcc/fortran/expr.c (working copy)
*************** is_subref_array (gfc_expr * e)
*** 984,989 ****
--- 984,994 ----
if (e->symtree->n.sym->attr.subref_array_pointer)
return true;
+ if (e->symtree->n.sym->ts.type == BT_CLASS
+ && e->symtree->n.sym->attr.dummy
+ && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer)
+ return true;
+
seen_array = false;
for (ref = e->ref; ref; ref = ref->next)
{
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 249865)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_array_dataptr_type (tree desc)
*** 125,132 ****
#define DATA_FIELD 0
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
! #define DIMENSION_FIELD 3
! #define CAF_TOKEN_FIELD 4
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
--- 125,133 ----
#define DATA_FIELD 0
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
! #define SPAN_FIELD 3
! #define DIMENSION_FIELD 4
! #define CAF_TOKEN_FIELD 5
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
*************** gfc_conv_descriptor_dtype (tree desc)
*** 244,249 ****
--- 245,280 ----
desc, field, NULL_TREE);
}
+ static tree
+ gfc_conv_descriptor_span (tree desc)
+ {
+ tree type;
+ tree field;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
+ gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ }
+
+ tree
+ gfc_conv_descriptor_span_get (tree desc)
+ {
+ return gfc_conv_descriptor_span (desc);
+ }
+
+ void
+ gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
+ tree value)
+ {
+ tree t = gfc_conv_descriptor_span (desc);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ }
+
tree
gfc_conv_descriptor_rank (tree desc)
*************** gfc_conv_shift_descriptor_lbound (stmtbl
*** 466,476 ****
--- 497,537 ----
}
+ /* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */
+
+ void
+ gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
+ tree *dtype_off, tree *dim_off,
+ tree *dim_size, tree *stride_suboff,
+ tree *lower_suboff, tree *upper_suboff)
+ {
+ tree field;
+ tree type;
+
+ type = TYPE_MAIN_VARIANT (desc_type);
+ field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
+ *data_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+ *dtype_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+ *dim_off = byte_position (field);
+ type = TREE_TYPE (TREE_TYPE (field));
+ *dim_size = TYPE_SIZE_UNIT (type);
+ field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
+ *stride_suboff = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
+ *lower_suboff = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
+ *upper_suboff = byte_position (field);
+ }
+
+
/* Cleanup those #defines. */
#undef DATA_FIELD
#undef OFFSET_FIELD
#undef DTYPE_FIELD
+ #undef SPAN_FIELD
#undef DIMENSION_FIELD
#undef CAF_TOKEN_FIELD
#undef STRIDE_SUBFIELD
*************** gfc_add_ss_to_loop (gfc_loopinfo * loop,
*** 720,725 ****
--- 781,864 ----
}
+ /* Returns true if the expression is an array pointer. */
+
+ static bool
+ is_pointer_array (tree expr)
+ {
+ if (flag_openmp)
+ return false;
+
+ if (expr == NULL_TREE
+ || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
+ || GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
+ return false;
+
+ if (TREE_CODE (expr) == VAR_DECL
+ && GFC_DECL_PTR_ARRAY_P (expr))
+ return true;
+
+ if (TREE_CODE (expr) == PARM_DECL
+ && GFC_DECL_PTR_ARRAY_P (expr))
+ return true;
+
+ if (TREE_CODE (expr) == INDIRECT_REF
+ && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
+ return true;
+
+ /* The field declaration is marked as an pointer array. */
+ if (TREE_CODE (expr) == COMPONENT_REF
+ && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
+ return true;
+
+ return false;
+ }
+
+
+ /* Return the span of an array. */
+
+ static tree
+ get_array_span (tree desc, gfc_expr *expr)
+ {
+ tree tmp;
+
+ if (is_pointer_array (desc))
+ /* This will have the span field set. */
+ tmp = gfc_conv_descriptor_span_get (desc);
+ else if (TREE_CODE (desc) == COMPONENT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
+ {
+ /* The descriptor is a class _data field and so use the vtable
+ size for the receiving span field. */
+ tmp = gfc_get_vptr_from_expr (desc);
+ tmp = gfc_vptr_size_get (tmp);
+ }
+ else if (expr && expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->ts.type == BT_CLASS
+ && expr->ref->type == REF_COMPONENT
+ && expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->next == NULL
+ && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
+ {
+ /* Dummys come in sometimes with the descriptor detached from
+ the class field or declaration. */
+ tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
+ tmp = gfc_vptr_size_get (tmp);
+ }
+ else
+ {
+ /* If none of the fancy stuff works, the span is the element
+ size of the array. */
+ tmp = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (tmp));
+ }
+ return tmp;
+ }
+
+
/* Generate an initializer for a static pointer or allocatable array. */
void
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3239,3249 ****
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && (is_subref_array (expr)
|| (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_FUNCTION))))
decl = expr->symtree->n.sym->backend_decl;
tmp = build_fold_indirect_ref_loc (input_location, info->data);
/* Use the vptr 'size' field to access a class the element of a class
--- 3378,3407 ----
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
index, info->offset);
! if (expr && ((is_subref_array (expr)
! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))
|| (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_FUNCTION))))
decl = expr->symtree->n.sym->backend_decl;
+ /* A pointer array component can be detected from its field decl. Fix
+ the descriptor, mark the resulting variable decl and pass it to
+ gfc_build_array_ref. */
+ if (is_pointer_array (info->descriptor))
+ {
+ if (TREE_CODE (info->descriptor) == COMPONENT_REF)
+ {
+ decl = gfc_evaluate_now (info->descriptor, &se->pre);
+ GFC_DECL_PTR_ARRAY_P (decl) = 1;
+ TREE_USED (decl) = 1;
+ }
+ else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
+ decl = TREE_OPERAND (info->descriptor, 0);
+
+ if (decl == NULL_TREE)
+ decl = info->descriptor;
+ }
+
tmp = build_fold_indirect_ref_loc (input_location, info->data);
/* Use the vptr 'size' field to access a class the element of a class
*************** build_array_ref (tree desc, tree offset,
*** 3288,3332 ****
{
tree tmp;
tree type;
! tree cdecl;
! bool classarray = false;
/* For class arrays the class declaration is stored in the saved
descriptor. */
if (INDIRECT_REF_P (desc)
&& DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
&& GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
! cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
TREE_OPERAND (desc, 0)));
else
! cdecl = desc;
/* Class container types do not always have the GFC_CLASS_TYPE_P
but the canonical type does. */
! if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
! && TREE_CODE (cdecl) == COMPONENT_REF)
{
! type = TREE_TYPE (TREE_OPERAND (cdecl, 0));
if (TYPE_CANONICAL (type)
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
! {
! type = TREE_TYPE (desc);
! classarray = true;
! }
! }
! else
! type = NULL;
!
! /* Class array references need special treatment because the assigned
! type size needs to be used to point to the element. */
! if (classarray)
! {
! type = gfc_get_element_type (type);
! tmp = TREE_OPERAND (cdecl, 0);
! tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
! tmp = fold_convert (build_pointer_type (type), tmp);
! tmp = build_fold_indirect_ref_loc (input_location, tmp);
! return tmp;
}
tmp = gfc_conv_array_data (desc);
--- 3446,3472 ----
{
tree tmp;
tree type;
! tree cdesc;
/* For class arrays the class declaration is stored in the saved
descriptor. */
if (INDIRECT_REF_P (desc)
&& DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
&& GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
! cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
TREE_OPERAND (desc, 0)));
else
! cdesc = desc;
/* Class container types do not always have the GFC_CLASS_TYPE_P
but the canonical type does. */
! if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
! && TREE_CODE (cdesc) == COMPONENT_REF)
{
! type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
if (TYPE_CANONICAL (type)
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
! vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
}
tmp = gfc_conv_array_data (desc);
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3350,3355 ****
--- 3490,3496 ----
tree offset, cst_offset;
tree tmp;
tree stride;
+ tree decl = NULL_TREE;
gfc_se indexse;
gfc_se tmpse;
gfc_symbol * sym = expr->symtree->n.sym;
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3494,3501 ****
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
! se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ?
! NULL_TREE : sym->backend_decl, se->class_vptr);
}
--- 3635,3665 ----
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
! /* A pointer array component can be detected from its field decl. Fix
! the descriptor, mark the resulting variable decl and pass it to
! build_array_ref. */
! if (!expr->ts.deferred && !sym->attr.codimension
! && is_pointer_array (se->expr))
! {
! if (TREE_CODE (se->expr) == COMPONENT_REF)
! {
! decl = gfc_evaluate_now (se->expr, &se->pre);
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
! TREE_USED (decl) = 1;
! }
! else if (TREE_CODE (se->expr) == INDIRECT_REF)
! decl = TREE_OPERAND (se->expr, 0);
! else
! decl = se->expr;
! }
! else if (expr->ts.deferred
! || (sym->ts.type == BT_CHARACTER
! && sym->attr.select_type_temporary))
! decl = sym->backend_decl;
! else if (sym->ts.type == BT_CLASS)
! decl = NULL_TREE;
!
! se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
}
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5648,5653 ****
--- 5812,5830 ----
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+ /* Pointer arrays need the span field to be set. */
+ if (is_pointer_array (se->expr)
+ || (expr->ts.type == BT_CLASS
+ && CLASS_DATA (expr)->attr.class_pointer))
+ {
+ if (expr3 && expr3_elem_size != NULL_TREE)
+ tmp = expr3_elem_size;
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
+ }
+
set_descriptor = gfc_finish_block (&set_descriptor_block);
if (status != NULL_TREE)
{
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6851,6856 ****
--- 7028,7037 ----
/* Add any offsets from subreferences. */
gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
subref_array_target, expr);
+
+ /* ....and set the span field. */
+ tmp = get_array_span (desc, expr);
+ gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
}
else if (se->want_pointer)
{
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 6886,6893 ****
--- 7067,7084 ----
se->ss = ss;
else
gcc_assert (se->ss == ss);
+
+ if (!is_pointer_array (se->expr))
+ {
+ tmp = gfc_get_element_type (TREE_TYPE (se->expr));
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (tmp));
+ gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
+ }
+
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
+
gfc_free_ss_chain (ss);
return;
}
*************** gfc_conv_expr_descriptor (gfc_se *se, gf
*** 7107,7115 ****
desc = info->descriptor;
if (se->direct_byref && !se->byref_noassign)
{
! /* For pointer assignments we fill in the destination. */
parm = se->expr;
parmtype = TREE_TYPE (parm);
}
else
{
--- 7298,7310 ----
desc = info->descriptor;
if (se->direct_byref && !se->byref_noassign)
{
! /* For pointer assignments we fill in the destination.... */
parm = se->expr;
parmtype = TREE_TYPE (parm);
+
+ /* ....and set the span field. */
+ tmp = get_array_span (desc, expr);
+ gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
}
else
{
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 7582,7587 ****
--- 7777,7783 ----
/* Every other type of array. */
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr);
+
if (size)
array_parameter_size (build_fold_indirect_ref_loc (input_location,
se->expr),
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 249865)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_conv_array_ubound (tree, int);
*** 152,160 ****
--- 152,164 ----
void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
/* Build expressions for accessing components of an array descriptor. */
+ void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tree *,
+ tree *, tree *, tree *);
+
tree gfc_conv_descriptor_data_get (tree);
tree gfc_conv_descriptor_data_addr (tree);
tree gfc_conv_descriptor_offset_get (tree);
+ tree gfc_conv_descriptor_span_get (tree);
tree gfc_conv_descriptor_dtype (tree);
tree gfc_conv_descriptor_rank (tree);
tree gfc_get_descriptor_dimension (tree);
*************** tree gfc_conv_descriptor_token (tree);
*** 165,170 ****
--- 169,175 ----
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree);
+ void gfc_conv_descriptor_span_set (stmtblock_t *, tree, tree);
void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 249865)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1517,1522 ****
--- 1517,1525 ----
/* Dummy variables should already have been created. */
gcc_assert (sym->backend_decl);
+ if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS)
+ GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
+
/* Create a character length variable. */
if (sym->ts.type == BT_CHARACTER)
{
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1751,1777 ****
if (sym->ts.type == BT_CHARACTER)
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
- else if (sym->attr.subref_array_pointer)
- /* We need the span for these beasts. */
- gfc_allocate_lang_decl (decl);
! if (sym->attr.subref_array_pointer)
! {
! tree span;
! GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
! span = build_decl (input_location,
! VAR_DECL, create_tmp_var_name ("span"),
! gfc_array_index_type);
! gfc_finish_var_decl (span, sym);
! TREE_STATIC (span) = TREE_STATIC (decl);
! DECL_ARTIFICIAL (span) = 1;
! GFC_DECL_SPAN (decl) = span;
! GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
! }
if (sym->ts.type == BT_CLASS)
! GFC_DECL_CLASS(decl) = 1;
sym->backend_decl = decl;
--- 1754,1771 ----
if (sym->ts.type == BT_CHARACTER)
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
! if (sym->assoc && sym->attr.subref_array_pointer)
! sym->attr.pointer = 1;
! if (sym->attr.pointer && sym->attr.dimension
! && !sym->ts.deferred
! && !(sym->attr.select_type_temporary
! && !sym->attr.subref_array_pointer))
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
if (sym->ts.type == BT_CLASS)
! GFC_DECL_CLASS(decl) = 1;
sym->backend_decl = decl;
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4269,4281 ****
if (sym->assoc)
continue;
! if (sym->attr.subref_array_pointer
! && GFC_DECL_SPAN (sym->backend_decl)
! && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
{
gfc_init_block (&tmpblock);
! gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
! build_int_cst (gfc_array_index_type, 0));
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
--- 4263,4277 ----
if (sym->assoc)
continue;
! if (sym->attr.pointer && sym->attr.dimension
! && !sym->attr.use_assoc
! && !sym->attr.host_assoc
! && !sym->attr.dummy
! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
{
gfc_init_block (&tmpblock);
! gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
! build_int_cst (gfc_array_index_type, 0));
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL_TREE);
}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 249865)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5413,5419 ****
}
if (e->expr_type == EXPR_VARIABLE
! && is_subref_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
--- 5413,5420 ----
}
if (e->expr_type == EXPR_VARIABLE
! && is_subref_array (e)
! && !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8223,8229 ****
stmtblock_t block;
tree desc;
tree tmp;
- tree decl;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
--- 8224,8229 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8412,8435 ****
gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length;
! /* If this is a subreference array pointer assignment, use the rhs
! descriptor element size for the lhs span. */
! if (expr1->symtree->n.sym->attr.subref_array_pointer)
! {
! decl = expr1->symtree->n.sym->backend_decl;
! gfc_init_se (&rse, NULL);
! rse.descriptor_only = 1;
! gfc_conv_expr (&rse, expr2);
! if (expr1->ts.type == BT_CLASS)
! trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
! NULL, NULL);
! tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
! tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
! if (!INTEGER_CST_P (tmp))
! gfc_add_block_to_block (&lse.post, &rse.pre);
! gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
! }
! else if (expr1->ts.type == BT_CLASS)
{
rse.expr = NULL_TREE;
rse.string_length = NULL_TREE;
--- 8412,8418 ----
gfc_conv_expr_descriptor (&lse, expr2);
strlen_rhs = lse.string_length;
! if (expr1->ts.type == BT_CLASS)
{
rse.expr = NULL_TREE;
rse.string_length = NULL_TREE;
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8446,8452 ****
{
rse.expr = gfc_class_data_get (rse.expr);
gfc_add_modify (&lse.pre, desc, rse.expr);
! }
else
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
--- 8429,8440 ----
{
rse.expr = gfc_class_data_get (rse.expr);
gfc_add_modify (&lse.pre, desc, rse.expr);
! /* Set the lhs span. */
! tmp = TREE_TYPE (rse.expr);
! tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
! tmp = fold_convert (gfc_array_index_type, tmp);
! gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
! }
else
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8492,8498 ****
converted in rse and now have to build the correct LHS
descriptor for it. */
! tree dtype, data;
tree offs, stride;
tree lbound, ubound;
--- 8480,8486 ----
converted in rse and now have to build the correct LHS
descriptor for it. */
! tree dtype, data, span;
tree offs, stride;
tree lbound, ubound;
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8505,8510 ****
--- 8493,8510 ----
data = gfc_conv_descriptor_data_get (rse.expr);
gfc_conv_descriptor_data_set (&block, desc, data);
+ /* Copy the span. */
+ if (TREE_CODE (rse.expr) == VAR_DECL
+ && GFC_DECL_PTR_ARRAY_P (rse.expr))
+ span = gfc_conv_descriptor_span_get (rse.expr);
+ else
+ {
+ tmp = TREE_TYPE (rse.expr);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+ }
+ gfc_conv_descriptor_span_set (&block, desc, span);
+
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
offs = gfc_conv_descriptor_offset_get (rse.expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 249865)
--- gcc/fortran/trans-intrinsic.c (working copy)
*************** conv_expr_ref_to_caf_ref (stmtblock_t *b
*** 1225,1234 ****
&& ref->u.c.component->attr.dimension)
{
tree arr_desc_token_offset;
! /* Get the token from the descriptor. */
! arr_desc_token_offset = gfc_advance_chain (
! TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)),
! 4 /* CAF_TOKEN_FIELD */);
arr_desc_token_offset
= compute_component_offset (arr_desc_token_offset,
TREE_TYPE (tmp));
--- 1225,1233 ----
&& ref->u.c.component->attr.dimension)
{
tree arr_desc_token_offset;
! /* Get the token field from the descriptor. */
! arr_desc_token_offset = TREE_OPERAND (
! gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
arr_desc_token_offset
= compute_component_offset (arr_desc_token_offset,
TREE_TYPE (tmp));
*************** conv_isocbinding_subroutine (gfc_code *c
*** 8129,8134 ****
--- 8128,8138 ----
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
+ /* Set the span field. */
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (&block, desc, tmp);
+
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 249865)
--- gcc/fortran/trans-io.c (working copy)
*************** gfc_trans_transfer (gfc_code * code)
*** 2563,2568 ****
--- 2563,2574 ----
gcc_assert (ref && ref->type == REF_ARRAY);
}
+ if (expr->ts.type != BT_CLASS
+ && expr->expr_type == EXPR_VARIABLE
+ && gfc_expr_attr (expr).pointer)
+ goto scalarize;
+
+
if (!(gfc_bt_struct (expr->ts.type)
|| expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
*************** gfc_trans_transfer (gfc_code * code)
*** 2597,2602 ****
--- 2603,2609 ----
goto finish_block_label;
}
+ scalarize:
/* Initialize the scalarizer. */
ss = gfc_walk_expr (expr);
gfc_init_loopinfo (&loop);
*************** gfc_trans_transfer (gfc_code * code)
*** 2612,2618 ****
--- 2619,2627 ----
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
+
gfc_conv_expr_reference (&se, expr);
+
if (expr->ts.type == BT_CLASS)
vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
else
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 249865)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1606,1612 ****
: e->symtree->n.sym->backend_decl;
tmp = gfc_get_element_type (TREE_TYPE (tmp));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
! gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
}
/* Done, register stuff as init / cleanup code. */
--- 1606,1612 ----
: e->symtree->n.sym->backend_decl;
tmp = gfc_get_element_type (TREE_TYPE (tmp));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
! gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
}
/* Done, register stuff as init / cleanup code. */
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c (revision 249865)
--- gcc/fortran/trans-types.c (working copy)
*************** along with GCC; see the file COPYING3.
*** 35,40 ****
--- 35,41 ----
#include "toplev.h" /* For rest_of_decl_compilation. */
#include "trans-types.h"
#include "trans-const.h"
+ #include "trans-array.h"
#include "dwarf2out.h" /* For struct array_descr_info. */
*************** gfc_get_array_descriptor_base (int dimen
*** 1782,1787 ****
--- 1783,1794 ----
gfc_array_index_type, &chain);
TREE_NO_WARNING (decl) = 1;
+ /* Add the span component. */
+ decl = gfc_add_field_to_struct_1 (fat_type,
+ get_identifier ("span"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (decl) = 1;
+
/* Build the array type for the stride and bound components. */
if (dimen + codimen > 0)
{
*************** gfc_get_derived_type (gfc_symbol * deriv
*** 2708,2713 ****
--- 2715,2725 ----
if (!c->backend_decl)
c->backend_decl = field;
+ if (c->attr.pointer && c->attr.dimension
+ && !(c->ts.type == BT_DERIVED
+ && strcmp (c->name, "_data") == 0))
+ GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
+
/* Do not add a caf_token field for classes' data components. */
if (codimen && !c->attr.dimension && !c->attr.codimension
&& (c->attr.allocatable || c->attr.pointer)
*************** gfc_get_array_descr_info (const_tree typ
*** 3146,3152 ****
{
int rank, dim;
bool indirect = false;
! tree etype, ptype, field, t, base_decl;
tree data_off, dim_off, dtype_off, dim_size, elem_size;
tree lower_suboff, upper_suboff, stride_suboff;
--- 3158,3164 ----
{
int rank, dim;
bool indirect = false;
! tree etype, ptype, t, base_decl;
tree data_off, dim_off, dtype_off, dim_size, elem_size;
tree lower_suboff, upper_suboff, stride_suboff;
*************** gfc_get_array_descr_info (const_tree typ
*** 3203,3226 ****
if (indirect)
base_decl = build1 (INDIRECT_REF, ptype, base_decl);
! if (GFC_TYPE_ARRAY_SPAN (type))
! elem_size = GFC_TYPE_ARRAY_SPAN (type);
! else
! elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
! field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
! data_off = byte_position (field);
! field = DECL_CHAIN (field);
! field = DECL_CHAIN (field);
! dtype_off = byte_position (field);
! field = DECL_CHAIN (field);
! dim_off = byte_position (field);
! dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
! field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
! stride_suboff = byte_position (field);
! field = DECL_CHAIN (field);
! lower_suboff = byte_position (field);
! field = DECL_CHAIN (field);
! upper_suboff = byte_position (field);
t = base_decl;
if (!integer_zerop (data_off))
--- 3215,3225 ----
if (indirect)
base_decl = build1 (INDIRECT_REF, ptype, base_decl);
! elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
!
! gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off,
! &dim_size, &stride_suboff,
! &lower_suboff, &upper_suboff);
t = base_decl;
if (!integer_zerop (data_off))
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 249865)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_addr_expr (tree type, tree t)
*** 305,310 ****
--- 305,371 ----
}
+ static tree
+ get_array_span (tree type, tree decl)
+ {
+ tree span;
+
+ /* Return the span for deferred character length array references. */
+ if (type && TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
+ && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF)
+ && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF
+ || TREE_CODE (decl) == FUNCTION_DECL
+ || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+ == DECL_CONTEXT (decl)))
+ {
+ span = TYPE_MAXVAL (TYPE_DOMAIN (type));
+ span = fold_convert (gfc_array_index_type, span);
+ }
+ /* Likewise for class array or pointer array references. */
+ else if (TREE_CODE (decl) == FIELD_DECL
+ || VAR_OR_FUNCTION_DECL_P (decl)
+ || TREE_CODE (decl) == PARM_DECL)
+ {
+ if (GFC_DECL_CLASS (decl))
+ {
+ /* When a temporary is in place for the class array, then the
+ original class' declaration is stored in the saved
+ descriptor. */
+ if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ else
+ {
+ /* Allow for dummy arguments and other good things. */
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+
+ /* Check if '_data' is an array descriptor. If it is not,
+ the array must be one of the components of the class
+ object, so return a null span. */
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
+ gfc_class_data_get (decl))))
+ return NULL_TREE;
+ }
+ span = gfc_class_vtab_size_get (decl);
+ }
+ else if (GFC_DECL_PTR_ARRAY_P (decl))
+ {
+ if (TREE_CODE (decl) == PARM_DECL)
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+ span = gfc_conv_descriptor_span_get (decl);
+ }
+ else
+ span = NULL_TREE;
+ }
+ else
+ span = NULL_TREE;
+
+ return span;
+ }
+
+
/* Build an ARRAY_REF with its natural type. */
tree
*************** gfc_build_array_ref (tree base, tree off
*** 312,318 ****
{
tree type = TREE_TYPE (base);
tree tmp;
! tree span;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
{
--- 373,379 ----
{
tree type = TREE_TYPE (base);
tree tmp;
! tree span = NULL_TREE;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
{
*************** gfc_build_array_ref (tree base, tree off
*** 331,407 ****
type = TREE_TYPE (type);
- /* Use pointer arithmetic for deferred character length array
- references. */
- if (type && TREE_CODE (type) == ARRAY_TYPE
- && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
- && (VAR_P (TYPE_MAXVAL (TYPE_DOMAIN (type)))
- || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF)
- && decl
- && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF
- || TREE_CODE (decl) == FUNCTION_DECL
- || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
- == DECL_CONTEXT (decl)))
- span = TYPE_MAXVAL (TYPE_DOMAIN (type));
- else
- span = NULL_TREE;
-
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
! /* If the array reference is to a pointer, whose target contains a
! subreference, use the span that is stored with the backend decl
! and reference the element with pointer arithmetic. */
! if ((decl && (TREE_CODE (decl) == FIELD_DECL
! || VAR_OR_FUNCTION_DECL_P (decl)
! || TREE_CODE (decl) == PARM_DECL)
! && ((GFC_DECL_SUBREF_ARRAY_P (decl)
! && !integer_zerop (GFC_DECL_SPAN (decl)))
! || GFC_DECL_CLASS (decl)
! || span != NULL_TREE))
! || vptr != NULL_TREE)
{
- if (decl)
- {
- if (GFC_DECL_CLASS (decl))
- {
- /* When a temporary is in place for the class array, then the
- original class' declaration is stored in the saved
- descriptor. */
- if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- else
- {
- /* Allow for dummy arguments and other good things. */
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
-
- /* Check if '_data' is an array descriptor. If it is not,
- the array must be one of the components of the class
- object, so return a normal array reference. */
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
- gfc_class_data_get (decl))))
- return build4_loc (input_location, ARRAY_REF, type, base,
- offset, NULL_TREE, NULL_TREE);
- }
-
- span = gfc_class_vtab_size_get (decl);
- }
- else if (GFC_DECL_SUBREF_ARRAY_P (decl))
- span = GFC_DECL_SPAN (decl);
- else if (span)
- span = fold_convert (gfc_array_index_type, span);
- else
- gcc_unreachable ();
- }
- else if (vptr)
- span = gfc_vptr_size_get (vptr);
- else
- gcc_unreachable ();
-
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
offset, span);
--- 392,414 ----
type = TREE_TYPE (type);
if (DECL_P (base))
TREE_ADDRESSABLE (base) = 1;
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
! /* If decl or vptr are non-null, pointer arithmetic for the array reference
! is likely. Generate the 'span' for the array reference. */
! if (vptr)
! span = gfc_vptr_size_get (vptr);
! else if (decl)
! span = get_array_span (type, decl);
!
! /* If a non-null span has been generated reference the element with
! pointer arithmetic. */
! if (span != NULL_TREE)
{
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
offset, span);
*************** gfc_build_array_ref (tree base, tree off
*** 412,419 ****
tmp = build_fold_indirect_ref_loc (input_location, tmp);
return tmp;
}
else
- /* Otherwise use a straightforward array reference. */
return build4_loc (input_location, ARRAY_REF, type, base, offset,
NULL_TREE, NULL_TREE);
}
--- 419,426 ----
tmp = build_fold_indirect_ref_loc (input_location, tmp);
return tmp;
}
+ /* Otherwise use a straightforward array reference. */
else
return build4_loc (input_location, ARRAY_REF, type, base, offset,
NULL_TREE, NULL_TREE);
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 249865)
--- gcc/fortran/trans.h (working copy)
*************** struct GTY(()) lang_decl {
*** 982,988 ****
#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
! #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
#define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
--- 982,988 ----
#define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node)
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
! #define GFC_DECL_PTR_ARRAY_P(node) DECL_LANG_FLAG_6(node)
#define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
Index: gcc/testsuite/gfortran.dg/assumed_type_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_type_2.f90 (revision 249865)
--- gcc/testsuite/gfortran.dg/assumed_type_2.f90 (working copy)
*************** end
*** 151,159 ****
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
--- 151,159 ----
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
Index: gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95
===================================================================
*** gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 (revision 249865)
--- gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 (working copy)
*************** program main
*** 16,20 ****
end program main
! Only the omp_data_i related loads should be annotated with cliques.
! ! { dg-final { scan-tree-dump-times "clique 1 base 1" 3 "ealias" } }
! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 4 "ealias" } }
--- 16,20 ----
end program main
! Only the omp_data_i related loads should be annotated with cliques.
! ! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } }
! ! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } }
Index: gcc/testsuite/gfortran.dg/no_arg_check_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/no_arg_check_2.f90 (revision 249865)
--- gcc/testsuite/gfortran.dg/no_arg_check_2.f90 (working copy)
*************** end
*** 133,141 ****
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
--- 133,141 ----
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
! ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } }
Index: gcc/testsuite/gfortran.dg/pointer_array_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_1.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_1.f90 (working copy)
***************
*** 0 ****
--- 1,60 ----
+ ! { dg-do run }
+ !
+ ! Check the fix for PR34640 comments 1 and 3.
+ !
+ ! This involves passing and returning pointer array components that
+ ! point to components of arrays of derived types.
+ !
+ MODULE test
+ IMPLICIT NONE
+ TYPE :: my_type
+ INTEGER :: value
+ integer :: tag
+ END TYPE
+ CONTAINS
+ SUBROUTINE get_values(values, switch)
+ INTEGER, POINTER :: values(:)
+ integer :: switch
+ TYPE(my_type), POINTER :: d(:)
+ allocate (d, source = [my_type(1,101), my_type(2,102)])
+ if (switch .eq. 1) then
+ values => d(:)%value
+ if (any (values .ne. [1,2])) print *, values(2)
+ else
+ values => d(:)%tag
+ if (any (values .ne. [101,102])) call abort
+ end if
+ END SUBROUTINE
+
+ function return_values(switch) result (values)
+ INTEGER, POINTER :: values(:)
+ integer :: switch
+ TYPE(my_type), POINTER :: d(:)
+ allocate (d, source = [my_type(1,101), my_type(2,102)])
+ if (switch .eq. 1) then
+ values => d(:)%value
+ if (any (values .ne. [1,2])) call abort
+ else
+ values => d(:)%tag
+ if (any (values([2,1]) .ne. [102,101])) call abort
+ end if
+ END function
+ END MODULE
+
+ use test
+ integer, pointer :: x(:)
+ type :: your_type
+ integer, pointer :: x(:)
+ end type
+ type(your_type) :: y
+
+ call get_values (x, 1)
+ if (any (x .ne. [1,2])) call abort
+ call get_values (y%x, 2)
+ if (any (y%x .ne. [101,102])) call abort
+
+ x => return_values (2)
+ if (any (x .ne. [101,102])) call abort
+ y%x => return_values (1)
+ if (any (y%x .ne. [1,2])) call abort
+ end
Index: gcc/testsuite/gfortran.dg/pointer_array_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_2.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_2.f90 (working copy)
***************
*** 0 ****
--- 1,143 ----
+ ! { dg-do compile }
+ !
+ ! Test the fix for PR40737 as part of the overall fix for PR34640.
+ !
+ ! Contributed by David Hough <dh458@oakapple.net>
+ !
+ module testmod
+
+ integer, parameter :: standard_integer = 1
+ integer, parameter :: int = KIND( standard_integer)
+
+ integer, parameter :: i8 = selected_int_kind(12)
+ integer, parameter :: i4 = selected_int_kind(8)
+ integer, parameter :: i2 = selected_int_kind(4)
+
+ integer, parameter :: standard_real = 1.
+ integer, parameter :: std_real = KIND( standard_real)
+
+ integer, parameter :: r8 = selected_real_kind(12)
+ integer, parameter :: r4 = selected_real_kind(6)
+ integer, parameter :: double = selected_real_kind(20)
+
+ integer, parameter :: name_string_length = 40
+ integer, parameter :: file_name_length = 60
+ integer, parameter :: text_string_length = 80
+ integer, parameter :: max_kwd_lgth = file_name_length
+
+ integer(int) :: bytes_per_int = 4
+ integer(int) :: bytes_per_real = 8
+ integer(int) :: workcomm, spincomm
+
+ integer(int), parameter :: nb_directions = 3, &
+ direction_x = 1, &
+ direction_y = 2, &
+ direction_z = 3, &
+ nb_ghost_cells = 5 ! might be different for the lagrange step?
+
+ integer(int), parameter :: ends = 4, &
+ lower_ghost = 1, &
+ lower_interior = 2, &
+ upper_interior = 3, &
+ upper_ghost = 4
+
+ ! Neighbors
+ integer(int), parameter :: side = 2, &
+ lower_end = 1, &
+ upper_end = 2
+
+
+ integer(int), parameter :: nb_variables = 5, &
+ ro_var = 1, &
+ ets_var = 2, &
+ u_var = 3, &
+ up1_var = 4, &
+ up2_var = 5, &
+ eis_var = 6, &
+ ecs_var = 7, &
+ p_var = 8, &
+ c_var = 9, &
+ nb_var_sortie = 9
+
+ type :: VARIABLES_LIGNE
+ sequence
+ real, pointer, dimension( :, :) :: l
+ end type VARIABLES_LIGNE
+
+ type VARIABLES_MAILLE
+ sequence
+ real(r8), dimension( nb_variables) :: cell_var
+ end type VARIABLES_MAILLE
+
+ integer(int), dimension( nb_directions) :: &
+ first_real_cell, & ! without ghost cells
+ last_real_cell, & !
+ nb_real_cells, & !
+ first_work_cell, & ! including ghost cells
+ last_work_cell, & !
+ nb_work_cells, & !
+ global_nb_cells ! number of real cells, for the entire grid
+
+ integer(int) :: dim_probleme ! dimension du probleme (1, 2 ou 3)
+
+ integer(int) :: largest_local_size ! the largest of the 3 dimensions of the local grid
+
+ ! Hydro variables of the actual domain
+ ! There are 3 copies of these, for use according to current work direction
+ type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) :: &
+ Hydro_vars_XYZ, &
+ Hydro_vars_YZX, &
+ Hydro_vars_ZXY
+
+ ! Pointers to current and next Hydro var arrays
+ type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars, &
+ Hydro_vars_next
+
+ ! Which of these 3 copies of the 3D arrays has been updated last
+ integer(int) :: last_updated_3D_array = 0
+
+ real(r8), pointer, dimension( :) :: &
+ ! Variables "permanentes" (entrant dans la projection)
+ Ro, & ! densite
+ Ets, & ! energie totale specifique
+ Um, & ! vitesse aux mailles, dans la direction de travail
+ Xn, & ! abscisse en fin de pas de temps
+ ! Variables en lecture seulement
+ Um_p1, & ! vitesse aux mailles, dans les directions
+ Um_p2, & ! orthogonales
+ Xa, & ! abscisses des noeuds en debut de pas de temps
+ Dxa, & ! longueur des mailles en debut de pas de temps
+ U_dxa ! inverses des longueurs des mailles
+
+ end module testmod
+
+
+ subroutine TF_AD_SPLITTING_DRIVER_PLANE
+
+ use testmod
+
+ implicit none
+ save
+
+ real(r8), allocatable, dimension( :) :: &
+ ! Variables maille recalculees a chaque pas de temps
+ Eis, & ! energie interne specifique (seulement pour calculer la pression)
+ Vit_son, & ! comme son nom l'indique
+ C_f_l, & ! nombre de Courant
+ Pm, & ! pression aux mailles
+ ! Variables aux noeuds
+ Un, & ! vitesse des noeuds
+ Pn ! pression aux noeuds
+
+
+ integer(int) :: i, j, k
+ integer(int) :: first_cell, last_cell
+
+ Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var)
+ Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var)
+ Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var)
+ Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var)
+ Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var)
+
+ end subroutine TF_AD_SPLITTING_DRIVER_PLANE
+
Index: gcc/testsuite/gfortran.dg/pointer_array_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_3.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_3.f90 (working copy)
***************
*** 0 ****
--- 1,51 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR40737 comment 17 as part of the overall fix for PR34640.
+ !
+ ! Contributed by Josh Hykes <joshuahykes@yahoo.com>
+ !
+ module test_mod
+ !
+ type t1
+ character(8) :: string
+ end type t1
+ !
+ type t2
+ integer :: tab
+ type(t1), pointer :: fp(:)
+ end type t2
+ !
+ type t3
+ integer :: tab
+ type(t2), pointer :: as
+ end type t3
+ !
+ type(t3), pointer :: as_typ(:) => null()
+ !
+ character(8), pointer, public :: p(:)
+ !
+ contains
+ !
+ subroutine as_set_alias (i)
+ !
+ implicit none
+ !
+ integer, intent(in) :: i
+ !
+ allocate (as_typ(2))
+ allocate (as_typ(1)%as)
+ allocate (as_typ(1)%as%fp(2), source = [t1("abcdefgh"),t1("ijklmnop")])
+ p => as_typ(i)%as%fp(:)%string
+ !
+ end subroutine as_set_alias
+ !
+ end module test_mod
+
+ program test_prog
+ use test_mod
+ call as_set_alias(1)
+ if (any (p .ne. ["abcdefgh","ijklmnop"])) call abort
+ deallocate (as_typ(1)%as%fp)
+ deallocate (as_typ(1)%as)
+ deallocate (as_typ)
+ end program test_prog
Index: gcc/testsuite/gfortran.dg/pointer_array_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_4.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_4.f90 (working copy)
***************
*** 0 ****
--- 1,75 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR57116 as part of the overall fix for PR34640.
+ !
+ ! Contributed by Reinhold Bader <Bader@lrz.de>
+ !
+ module mod_rtti_ptr
+ implicit none
+ type :: foo
+ real :: v
+ integer :: i
+ end type foo
+ contains
+ subroutine extract(this, v, ic)
+ class(*), target :: this(:)
+ real, pointer :: v(:)
+ integer :: ic
+ select type (this)
+ type is (real)
+ v => this(ic:)
+ class is (foo)
+ v => this(ic:)%v
+ end select
+ end subroutine extract
+ end module
+
+ program prog_rtti_ptr
+ use mod_rtti_ptr
+ class(*), allocatable, target :: o(:)
+ real, pointer :: v(:)
+
+ allocate(o(3), source=[1.0, 2.0, 3.0])
+ call extract(o, v, 2)
+ if (size(v) == 2 .and. all (v == [2.0, 3.0])) then
+ deallocate(o)
+ else
+ call abort
+ end if
+
+ allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)])
+ call extract(o, v, 2)
+ if (size(v) == 2 .and. all (v == [4.0, 5.0])) then
+ deallocate(o)
+ else
+ call abort
+ end if
+
+ ! The rest tests the case in comment 2 <janus@gcc.gnu.org>
+
+ call extract1 (v, 1)
+ if (any (v /= [1.0, 2.0])) call abort
+ call extract1 (v, 2) ! Call to deallocate pointer.
+
+ contains
+ subroutine extract1(v, flag)
+ type :: foo
+ real :: v
+ character(4) :: str
+ end type
+ class(foo), pointer, save :: this(:)
+ real, pointer :: v(:)
+ integer :: flag
+
+ if (flag == 1) then
+ allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")])
+ select type (this)
+ class is (foo)
+ v => this(1:2)%v
+ end select
+ else
+ deallocate (this)
+ end if
+ end subroutine
+
+ end program prog_rtti_ptr
Index: gcc/testsuite/gfortran.dg/pointer_array_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_5.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_5.f90 (working copy)
***************
*** 0 ****
--- 1,65 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ program change_field_type
+ use, intrinsic :: iso_c_binding
+ implicit none
+ REAL(kind=c_float), POINTER :: vector_comp(:)
+ TYPE, BIND(C) :: scalar_vector
+ REAL(kind=c_float) :: scalar
+ REAL(kind=c_float) :: vec(3)
+ END TYPE
+ TYPE, BIND(C) :: scalar_vector_matrix
+ REAL(kind=c_float) :: scalar
+ REAL(kind=c_float) :: vec(3)
+ REAL(kind=c_float) :: mat(3,3)
+ END TYPE
+ CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:)
+ real, pointer :: v1(:)
+
+ allocate(one_d_field(3), &
+ source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), &
+ scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), &
+ scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) )
+
+ call extract_vec(one_d_field, 1, 2)
+ if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) call abort
+ deallocate(one_d_field) ! v1 becomes undefined
+
+ allocate(one_d_field(1), &
+ source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), &
+ reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), &
+ (/3, 3/) ) ) /) )
+
+ call extract_vec(one_d_field, 2, 1)
+ if (abs (vector_comp(1) + 1.0) > 1e-4) call abort
+ call extract_vec(one_d_field, 2, 3)
+ if (abs (vector_comp(1) - 1.0) > 1e-4) call abort
+ deallocate(one_d_field) ! v1 becomes undefined
+ contains
+ subroutine extract_vec(field, tag, ic)
+ use, intrinsic :: iso_c_binding
+ CLASS(*), TARGET :: field(:)
+ INTEGER(kind=c_int), value :: tag, ic
+
+ type(scalar_vector), pointer :: sv(:)
+ type(scalar_vector_matrix), pointer :: svm(:)
+
+ select type (field)
+ type is (real(c_float))
+ vector_comp => field
+ class default
+ select case (tag)
+ case (1)
+ sv => field
+ vector_comp => sv(:)%vec(ic)
+ case (2)
+ svm => field
+ vector_comp => svm(:)%vec(ic)
+ end select
+ end select
+ end subroutine
+ end program
Index: gcc/testsuite/gfortran.dg/pointer_array_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_6.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_6.f90 (working copy)
***************
*** 0 ****
--- 1,28 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR57019 comment 4 as part of the overall fix for PR34640.
+ !
+ ! Contributed by <thambsup@gmail.com>
+ !
+ type cParticle
+ real(4) :: v(3)
+ endtype cParticle
+
+ type pCItem
+ type(cParticle) :: Ele
+ end type pCItem
+
+ type(pCItem), target, dimension(1:1,1:1) :: pCellArray
+ type(cParticle), pointer, dimension(:,:) :: pArray
+ real(4), pointer, dimension(:) :: v_pointer
+ real(4), dimension(3) :: v_real = 99.
+
+ pArray => pCellArray%Ele
+ v_pointer => pArray(1,1)%v;
+ v_pointer = v_real !OK %%%%%%%%%%%%
+ if (any (int (pArray(1,1)%v) .ne. 99)) call abort
+
+ v_real = 88
+ pArray(1,1)%v = v_real !SEGFAULT %%%%%%%%%%%%%%%%%%%%%%%%
+ if (any (int (v_pointer) .ne. 88)) call abort
+ end
Index: gcc/testsuite/gfortran.dg/pointer_array_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_7.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_7.f90 (working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! { dg-do run }
+ !
+ ! Test for the fix for PR34640. In this case, final testing of the
+ ! patch revealed that in some cases the actual descriptor was not
+ ! being passed to procedure dummy pointers.
+ !
+ ! Contributed by Thomas Koenig <tkoenig@netcologne.de>
+ !
+ module x
+ use iso_c_binding
+ implicit none
+ type foo
+ complex :: c
+ integer :: i
+ end type foo
+ contains
+ subroutine printit(c, a)
+ complex, pointer, dimension(:) :: c
+ integer :: i
+ integer(kind=8) :: a
+ a = transfer(c_loc(c(2)),a)
+ end subroutine printit
+ end module x
+
+ program main
+ use x
+ use iso_c_binding
+ implicit none
+ type(foo), dimension(5), target :: a
+ integer :: i
+ complex, dimension(:), pointer :: pc
+ integer(kind=8) :: s1, s2, s3
+ a%i = 0
+ do i=1,5
+ a(i)%c = cmplx(i**2,i)
+ end do
+ pc => a%c
+ call printit(pc, s3)
+
+ s1 = transfer(c_loc(a(2)%c),s1)
+ if (s1 /= s3) call abort
+
+ s2 = transfer(c_loc(pc(2)),s2)
+ if (s2 /= s3) call abort
+
+ end program main
Index: gcc/testsuite/gfortran.dg/pointer_array_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_8.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_8.f90 (working copy)
***************
*** 0 ****
--- 1,80 ----
+ ! { dg-do run }
+ !
+ ! Make sure that the fix for pr34640 works with class pointers.
+ !
+ type :: mytype
+ real :: r
+ integer :: i
+ end type
+
+ type :: thytype
+ real :: r
+ integer :: i
+ type(mytype) :: der
+ end type
+
+ type(thytype), dimension(0:2), target :: tgt
+ class(*), dimension(:), pointer :: cptr
+ class(mytype), dimension(:), pointer :: cptr1
+ integer :: i
+ integer(8) :: s1, s2
+
+ tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)]
+
+ cptr => tgt%i
+
+ s1 = loc(cptr)
+ call foo (cptr, s2) ! Check bounds not changed...
+ if (s1 .ne. s2) Call abort ! ...and that the descriptor is passed.
+
+ select type (cptr)
+ type is (integer)
+ if (any (cptr .ne. [1,2,3])) call abort ! Check the the scalarizer works.
+ if (cptr(1) .ne. 2) call abort ! Check ordinary array indexing.
+ end select
+
+ cptr(1:3) => tgt%der%r ! Something a tad more complicated!
+
+ select type (cptr)
+ type is (real)
+ if (any (int(cptr) .ne. [2,4,6])) call abort
+ if (any (int(cptr([2,3,1])) .ne. [4,6,2])) call abort
+ if (int(cptr(3)) .ne. 6) call abort
+ end select
+
+ cptr1(1:3) => tgt%der
+
+ s1 = loc(cptr1)
+ call bar(cptr1, s2)
+ if (s1 .ne. s2) Call abort ! Check that the descriptor is passed.
+
+ select type (cptr1)
+ type is (mytype)
+ if (any (cptr1%i .ne. [2,4,6])) call abort
+ if (cptr1(2)%i .ne. 4) call abort
+ end select
+
+ contains
+
+ subroutine foo (arg, addr)
+ class(*), dimension(:), pointer :: arg
+ integer(8) :: addr
+ addr = loc(arg)
+ select type (arg)
+ type is (integer)
+ if (any (arg .ne. [1,2,3])) call abort ! Check the the scalarizer works.
+ if (arg(1) .ne. 2) call abort ! Check ordinary array indexing.
+ end select
+ end subroutine
+
+ subroutine bar (arg, addr)
+ class(mytype), dimension(:), pointer :: arg
+ integer(8) :: addr
+ addr = loc(arg)
+ select type (arg)
+ type is (mytype)
+ if (any (arg%i .ne. [2,4,6])) call abort
+ if (arg(2)%i .ne. 4) call abort
+ end select
+ end subroutine
+ end
Index: gcc/testsuite/gfortran.dg/pointer_array_component_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 (working copy)
***************
*** 0 ****
--- 1,47 ----
+ ! { dg-do run }
+ !
+ ! Check the fix for PR34640 comment 28.
+ !
+ ! This involves pointer array components that point to components of arrays
+ ! of derived types.
+ !
+ type var_tables
+ real, pointer :: rvar(:)
+ end type
+
+ type real_vars
+ real r
+ real :: index
+ end type
+
+ type(var_tables) :: vtab_r
+ type(real_vars), target :: x(2)
+ real, pointer :: z(:)
+ real :: y(2)
+
+ x = [real_vars (11.0, 1.0), real_vars (42.0, 2.0)]
+ vtab_r%rvar => x%r
+ if (any (abs (vtab_r%rvar - [11.0, 42.0]) > 1.0e-5)) call abort ! Check skipping 'index; is OK.
+
+ y = vtab_r%rvar
+ if (any (abs (y - [11.0, 42.0]) > 1.0e-5)) call abort ! Check that the component is usable in assignment.
+
+ call foobar (vtab_r, [11.0, 42.0])
+
+ vtab_r = barfoo ()
+
+ call foobar (vtab_r, [111.0, 142.0])
+
+ contains
+ subroutine foobar (vtab, array)
+ type(var_tables) :: vtab
+ real :: array (:)
+ if (any (abs (vtab%rvar - array) > 1.0e-5)) call abort ! Check passing as a dummy.
+ if (abs (vtab%rvar(2) - array(2)) > 1.0e-5) call abort ! Check component reference.
+ end subroutine
+
+ function barfoo () result(res)
+ type(var_tables) :: res
+ allocate (res%rvar(2), source = [111.0, 142.0]) ! Check allocation
+ end function
+ end
Index: gcc/testsuite/gfortran.dg/pointer_array_component_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 (working copy)
***************
*** 0 ****
--- 1,43 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR34640. In the first version of the fix, the first
+ ! testcase in PR51218 failed with a segfault. This test extracts the
+ ! failing part and checks that all is well.
+ !
+ type t_info_block
+ integer :: n = 0 ! number of elements
+ end type t_info_block
+ !
+ type t_dec_info
+ integer :: n = 0 ! number of elements
+ integer :: n_b = 0 ! number of blocks
+ type (t_info_block) ,pointer :: b (:) => NULL() ! info blocks
+ end type t_dec_info
+ !
+ type t_vector_segm
+ integer :: n = 0 ! number of elements
+ real ,pointer :: x(:) => NULL() ! coefficients
+ end type t_vector_segm
+ !
+ type t_vector
+ type (t_dec_info) ,pointer :: info => NULL() ! decomposition info
+ integer :: n = 0 ! number of elements
+ integer :: n_s = 0 ! number of segments
+ integer :: alloc_l = 0 ! allocation level
+ type (t_vector_segm) ,pointer :: s (:) => NULL() ! vector blocks
+ end type t_vector
+
+
+ type(t_vector) :: z
+ type(t_vector_segm), pointer :: ss
+
+ allocate (z%s(2))
+ do i = 1, 2
+ ss => z%s(i)
+ allocate (ss%x(2), source = [1.0, 2.0]*real(i))
+ end do
+
+ ! These lines would segfault.
+ if (int (sum (z%s(1)%x)) .ne. 3) call abort
+ if (int (sum (z%s(1)%x * z%s(2)%x)) .ne. 10) call abort
+ end
Index: gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 (revision 249865)
--- gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 (working copy)
*************** PROGRAM X
*** 22,28 ****
CONTAINS
SUBROUTINE Z(Q)
INTEGER, POINTER :: Q(:)
! Q(1:3:2) = 999
END SUBROUTINE Z
END PROGRAM X
--- 22,30 ----
CONTAINS
SUBROUTINE Z(Q)
INTEGER, POINTER :: Q(:)
! integer :: off
! off = lbound(Q, 1) - 1
! Q(1+off : 3+off : 2) = 999
END SUBROUTINE Z
END PROGRAM X
Index: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 249865)
--- libgfortran/libgfortran.h (working copy)
*************** struct {\
*** 339,344 ****
--- 339,345 ----
type *base_addr;\
size_t offset;\
index_type dtype;\
+ index_type span;\
descriptor_dimension dim[r];\
}
More information about the Gcc-patches
mailing list