* [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
@ 2017-06-24 10:48 Paul Richard Thomas
2017-06-25 10:59 ` Thomas Koenig
` (2 more replies)
0 siblings, 3 replies; 15+ messages in thread
From: Paul Richard Thomas @ 2017-06-24 10:48 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5173 bytes --]
Dear All,
Please find attached a draft patch for the above PR, together with PRs
40737, 55763, 57019 and 57116. These PRs constitute problems
associated with the last F95 feature that gfortran does not completely
implement.
I want to sound out if this is acceptable as the way to fix these
problems before going to the trouble of doing the final clean up;
especially of trans.c (gfc_build_array_ref) and
trans-array.c(build_array_ref).
The problem concerns pointers to derived type array components. eg:
pointer_array(:) => derived_array (:)%component
At present gfortran uses a rather crude fix, where a 'span' variable
with value of sizeof(element of derived_array) is used for pointer
arithmetic to access elements of the array;
&pointer_array(i) = &derived_array(1)%component + span*(i-1)
The difficulty of using a variable 'span' is that it is not passed to
procedures and it is not available to array pointer components. This
patch fixes this by the introduction of a span field in the array
descriptor. Note that this is only used for intrinsic type, pointer
arrays in this version of the patch. A considerable simplification
would arise from using the span field in class arrays too. This might
well be one result of the clean up mentioned above.
Tobias Burnus and I have been putting off fixing these PRs for a long
time because of the pending array descriptor reform. However, work on
fortran-dev has once again stopped and neither I nor, I think, anybody
else has the time to restart this work anytime soon.
pointer[1,2].f90 in the libgomp testsuite fail if this modification to
array referencing is exposed to them. For the time being,
trans-array.c(is_pointer_array) has:
+ if (flag_openmp)
+ return false;
to switch off the modification. I will come back to this during the
clean up, with the hope of putting it right.
Bootstraps and regtests on FC23/x86_64 - OK to proceed to completion
and submission?
Paul
2017-06-24 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
PR fortran/40737
PR fortran/55763
PR fortran/57019
PR fortran/57116
* 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_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.
(gfc_conv_array_ref): Similarly set 'decl'.
(gfc_array_allocate): Set the span field if this is a pointer
array.
(gfc_conv_expr_descriptor): Set the span field for pointer
assignments.
* trans-array.h: Prototypes for gfc_conv_descriptor_span_get
and gfc_conv_descriptor_span_set added.
* trans.c (gfc_build_array_ref): GFC_DECL_SUBREF_ARRAY_P change
to GFC_DECL_PTR_ARRAY_P and defreference if a PARM_DECL.
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 the
originating scope.
* trans-expr.c (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.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
as GFC_DECL_PTR_ARRAY_P.
* 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): Jump one more in the DECL_CHAIN to
access the offset field.
2017-06-24 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_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.
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-06-24 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
* libgfortran/libgfortran.h: Add span field to descriptor.
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 49214 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 249050)
--- 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
*** 471,476 ****
--- 502,508 ----
#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 ****
--- 752,831 ----
}
+ /* 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;
+
+ /* 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
--- 3345,3371 ----
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;
+ }
+ 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
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3350,3355 ****
--- 3472,3478 ----
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);
}
--- 3617,3643 ----
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
! 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 ****
--- 5790,5803 ----
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))
+ {
+ 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 ****
--- 7001,7010 ----
/* 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 ****
--- 7040,7058 ----
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
{
--- 7272,7284 ----
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
{
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 249050)
--- gcc/fortran/trans-array.h (working copy)
*************** void gfc_trans_array_cobounds (tree, stm
*** 155,160 ****
--- 155,161 ----
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 ****
--- 166,172 ----
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.c
===================================================================
*** gcc/fortran/trans.c (revision 249050)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 358,365 ****
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)
--- 358,364 ----
if ((decl && (TREE_CODE (decl) == FIELD_DECL
|| VAR_OR_FUNCTION_DECL_P (decl)
|| TREE_CODE (decl) == PARM_DECL)
! && ((GFC_DECL_PTR_ARRAY_P (decl))
|| GFC_DECL_CLASS (decl)
|| span != NULL_TREE))
|| vptr != NULL_TREE)
*************** gfc_build_array_ref (tree base, tree off
*** 390,397 ****
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
--- 389,400 ----
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 if (span)
span = fold_convert (gfc_array_index_type, span);
else
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 249050)
--- 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,1770 ----
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)
! 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);
}
--- 4262,4276 ----
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 249050)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8222,8228 ****
stmtblock_t block;
tree desc;
tree tmp;
- tree decl;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
--- 8222,8227 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8411,8434 ****
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;
--- 8410,8416 ----
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 *
*** 8445,8451 ****
{
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,
--- 8427,8438 ----
{
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 *
*** 8491,8497 ****
converted in rse and now have to build the correct LHS
descriptor for it. */
! tree dtype, data;
tree offs, stride;
tree lbound, ubound;
--- 8478,8484 ----
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 *
*** 8504,8509 ****
--- 8491,8508 ----
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.h
===================================================================
*** gcc/fortran/trans.h (revision 249050)
--- 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/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 249050)
--- 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 249050)
--- 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 249050)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1602,1608 ****
: 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. */
--- 1602,1608 ----
: 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 249050)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_array_descriptor_base (int dimen
*** 1782,1787 ****
--- 1782,1793 ----
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 ****
--- 2714,2724 ----
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
*** 3203,3218 ****
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)));
--- 3214,3227 ----
if (indirect)
base_decl = build1 (INDIRECT_REF, ptype, base_decl);
! 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);
+ 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)));
Index: gcc/testsuite/gfortran.dg/assumed_type_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_type_2.f90 (revision 249050)
--- 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 249050)
--- 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 249050)
--- 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_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
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-06-24 10:48 [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer Paul Richard Thomas
@ 2017-06-25 10:59 ` Thomas Koenig
2017-06-25 11:43 ` Paul Richard Thomas
2017-07-01 18:17 ` Paul Richard Thomas
2 siblings, 0 replies; 15+ messages in thread
From: Thomas Koenig @ 2017-06-25 10:59 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
Hi Paul,
> I want to sound out if this is acceptable as the way to fix these
> problems before going to the trouble of doing the final clean up;
> especially of trans.c (gfc_build_array_ref) and
> trans-array.c(build_array_ref).
The method you use looks OK to me, and the time till
completion of the Great Array Descrptor Reform (TM)
tends to become longer, not shorter.
So, OK to proceed from my side.
And thank you very much for taking on this thorny (and, for gfortran,
very fundamental problem).
Regards
Thomas
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-06-24 10:48 [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer Paul Richard Thomas
2017-06-25 10:59 ` Thomas Koenig
@ 2017-06-25 11:43 ` Paul Richard Thomas
2017-07-01 18:17 ` Paul Richard Thomas
2 siblings, 0 replies; 15+ messages in thread
From: Paul Richard Thomas @ 2017-06-25 11:43 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 5869 bytes --]
Dear All,
Dominique pointed out that the changes to libgfortran.h were missing
from the patch. This came about because I wrongly named
kernels-alias-4.f95 in the diff so it was missing too. Please find
attached the complete patch.
Thomas, thanks for the early feedback.
Paul
On 24 June 2017 at 11:48, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> Please find attached a draft patch for the above PR, together with PRs
> 40737, 55763, 57019 and 57116. These PRs constitute problems
> associated with the last F95 feature that gfortran does not completely
> implement.
>
> I want to sound out if this is acceptable as the way to fix these
> problems before going to the trouble of doing the final clean up;
> especially of trans.c (gfc_build_array_ref) and
> trans-array.c(build_array_ref).
>
> The problem concerns pointers to derived type array components. eg:
> pointer_array(:) => derived_array (:)%component
>
> At present gfortran uses a rather crude fix, where a 'span' variable
> with value of sizeof(element of derived_array) is used for pointer
> arithmetic to access elements of the array;
> &pointer_array(i) = &derived_array(1)%component + span*(i-1)
>
> The difficulty of using a variable 'span' is that it is not passed to
> procedures and it is not available to array pointer components. This
> patch fixes this by the introduction of a span field in the array
> descriptor. Note that this is only used for intrinsic type, pointer
> arrays in this version of the patch. A considerable simplification
> would arise from using the span field in class arrays too. This might
> well be one result of the clean up mentioned above.
>
> Tobias Burnus and I have been putting off fixing these PRs for a long
> time because of the pending array descriptor reform. However, work on
> fortran-dev has once again stopped and neither I nor, I think, anybody
> else has the time to restart this work anytime soon.
>
> pointer[1,2].f90 in the libgomp testsuite fail if this modification to
> array referencing is exposed to them. For the time being,
> trans-array.c(is_pointer_array) has:
> + if (flag_openmp)
> + return false;
> to switch off the modification. I will come back to this during the
> clean up, with the hope of putting it right.
>
> Bootstraps and regtests on FC23/x86_64 - OK to proceed to completion
> and submission?
>
> Paul
>
>
> 2017-06-24 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/34640
> PR fortran/40737
> PR fortran/55763
> PR fortran/57019
> PR fortran/57116
>
> * 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_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.
> (gfc_conv_array_ref): Similarly set 'decl'.
> (gfc_array_allocate): Set the span field if this is a pointer
> array.
> (gfc_conv_expr_descriptor): Set the span field for pointer
> assignments.
> * trans-array.h: Prototypes for gfc_conv_descriptor_span_get
> and gfc_conv_descriptor_span_set added.
> * trans.c (gfc_build_array_ref): GFC_DECL_SUBREF_ARRAY_P change
> to GFC_DECL_PTR_ARRAY_P and defreference if a PARM_DECL.
> 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 the
> originating scope.
> * trans-expr.c (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.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
> as GFC_DECL_PTR_ARRAY_P.
> * 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): Jump one more in the DECL_CHAIN to
> access the offset field.
>
>
> 2017-06-24 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_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.
>
> 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-06-24 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/34640
> * libgfortran/libgfortran.h: Add span field to descriptor.
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 50642 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 249050)
--- 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
*** 471,476 ****
--- 502,508 ----
#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 ****
--- 752,831 ----
}
+ /* 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;
+
+ /* 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
--- 3345,3371 ----
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;
+ }
+ 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
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3350,3355 ****
--- 3472,3478 ----
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);
}
--- 3617,3643 ----
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
! 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 ****
--- 5790,5803 ----
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))
+ {
+ 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 ****
--- 7001,7010 ----
/* 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 ****
--- 7040,7058 ----
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
{
--- 7272,7284 ----
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
{
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 249050)
--- gcc/fortran/trans-array.h (working copy)
*************** void gfc_trans_array_cobounds (tree, stm
*** 155,160 ****
--- 155,161 ----
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 ****
--- 166,172 ----
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.c
===================================================================
*** gcc/fortran/trans.c (revision 249050)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 358,365 ****
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)
--- 358,364 ----
if ((decl && (TREE_CODE (decl) == FIELD_DECL
|| VAR_OR_FUNCTION_DECL_P (decl)
|| TREE_CODE (decl) == PARM_DECL)
! && ((GFC_DECL_PTR_ARRAY_P (decl))
|| GFC_DECL_CLASS (decl)
|| span != NULL_TREE))
|| vptr != NULL_TREE)
*************** gfc_build_array_ref (tree base, tree off
*** 390,397 ****
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
--- 389,400 ----
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 if (span)
span = fold_convert (gfc_array_index_type, span);
else
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 249050)
--- 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,1770 ----
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)
! 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);
}
--- 4262,4276 ----
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 249050)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8222,8228 ****
stmtblock_t block;
tree desc;
tree tmp;
- tree decl;
bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
--- 8222,8227 ----
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8411,8434 ****
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;
--- 8410,8416 ----
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 *
*** 8445,8451 ****
{
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,
--- 8427,8438 ----
{
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 *
*** 8491,8497 ****
converted in rse and now have to build the correct LHS
descriptor for it. */
! tree dtype, data;
tree offs, stride;
tree lbound, ubound;
--- 8478,8484 ----
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 *
*** 8504,8509 ****
--- 8491,8508 ----
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.h
===================================================================
*** gcc/fortran/trans.h (revision 249050)
--- 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/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 249050)
--- 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 249050)
--- 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 249050)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1602,1608 ****
: 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. */
--- 1602,1608 ----
: 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 249050)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_get_array_descriptor_base (int dimen
*** 1782,1787 ****
--- 1782,1793 ----
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 ****
--- 2714,2724 ----
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
*** 3203,3218 ****
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)));
--- 3214,3227 ----
if (indirect)
base_decl = build1 (INDIRECT_REF, ptype, base_decl);
! 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);
+ 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)));
Index: gcc/testsuite/gfortran.dg/assumed_type_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_type_2.f90 (revision 249050)
--- 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 249050)
--- 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 249050)
--- 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_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/goacc/kernels-alias-4.f95
===================================================================
*** gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 (revision 249050)
--- 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: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 249050)
--- 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];\
}
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-06-24 10:48 [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer Paul Richard Thomas
2017-06-25 10:59 ` Thomas Koenig
2017-06-25 11:43 ` Paul Richard Thomas
@ 2017-07-01 18:17 ` Paul Richard Thomas
2017-07-04 21:04 ` Thomas Koenig
2 siblings, 1 reply; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-01 18:17 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 9879 bytes --]
Dear All,
Encouraged by the response to the earlier version of the patch, please
find attached the final version that includes the promised cleanup;
except for the libgomp problem for which the fix remains the same.
Please find some descriptive material in the original submission below.
Two parts of the patch, most notably the new function
trans-array.c(gfc_get_descriptor_offsets_for_info), replace bits of
code that broke the API for access to array descriptor fields. Thanks
to Andre for spotting one of the sources of this API breaking, which
cost me a lot of time.
I presume that the module version number has to be bumped up?
Bootstraps and regtests on FC23/x86_64 - OK for trunk?
Regards
Paul
2017-07-01 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
PR fortran/40737
PR fortran/55763
PR fortran/57019
PR fortran/57116
* 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.
(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.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-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_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.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
as GFC_DECL_PTR_ARRAY_P.
* 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.
2017-07-01 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_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.
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-01 Paul Thomas <pault@gcc.gnu.org>
PR fortran/34640
* libgfortran/libgfortran.h: Add span field to descriptor.
On 24 June 2017 at 11:48, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> Please find attached a draft patch for the above PR, together with PRs
> 40737, 55763, 57019 and 57116. These PRs constitute problems
> associated with the last F95 feature that gfortran does not completely
> implement.
>
> I want to sound out if this is acceptable as the way to fix these
> problems before going to the trouble of doing the final clean up;
> especially of trans.c (gfc_build_array_ref) and
> trans-array.c(build_array_ref).
>
> The problem concerns pointers to derived type array components. eg:
> pointer_array(:) => derived_array (:)%component
>
> At present gfortran uses a rather crude fix, where a 'span' variable
> with value of sizeof(element of derived_array) is used for pointer
> arithmetic to access elements of the array;
> &pointer_array(i) = &derived_array(1)%component + span*(i-1)
>
> The difficulty of using a variable 'span' is that it is not passed to
> procedures and it is not available to array pointer components. This
> patch fixes this by the introduction of a span field in the array
> descriptor. Note that this is only used for intrinsic type, pointer
> arrays in this version of the patch. A considerable simplification
> would arise from using the span field in class arrays too. This might
> well be one result of the clean up mentioned above.
>
> Tobias Burnus and I have been putting off fixing these PRs for a long
> time because of the pending array descriptor reform. However, work on
> fortran-dev has once again stopped and neither I nor, I think, anybody
> else has the time to restart this work anytime soon.
>
> pointer[1,2].f90 in the libgomp testsuite fail if this modification to
> array referencing is exposed to them. For the time being,
> trans-array.c(is_pointer_array) has:
> + if (flag_openmp)
> + return false;
> to switch off the modification. I will come back to this during the
> clean up, with the hope of putting it right.
>
> Bootstraps and regtests on FC23/x86_64 - OK to proceed to completion
> and submission?
>
> Paul
>
>
> 2017-06-24 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/34640
> PR fortran/40737
> PR fortran/55763
> PR fortran/57019
> PR fortran/57116
>
> * 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_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.
> (gfc_conv_array_ref): Similarly set 'decl'.
> (gfc_array_allocate): Set the span field if this is a pointer
> array.
> (gfc_conv_expr_descriptor): Set the span field for pointer
> assignments.
> * trans-array.h: Prototypes for gfc_conv_descriptor_span_get
> and gfc_conv_descriptor_span_set added.
> * trans.c (gfc_build_array_ref): GFC_DECL_SUBREF_ARRAY_P change
> to GFC_DECL_PTR_ARRAY_P and defreference if a PARM_DECL.
> 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 the
> originating scope.
> * trans-expr.c (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.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P,
> as GFC_DECL_PTR_ARRAY_P.
> * 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): Jump one more in the DECL_CHAIN to
> access the offset field.
>
>
> 2017-06-24 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_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.
>
> 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-06-24 Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/34640
> * libgfortran/libgfortran.h: Add span field to descriptor.
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
[-- Attachment #2: submit0107.diff --]
[-- Type: text/plain, Size: 60697 bytes --]
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,860 ----
}
+ /* 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;
+
+ /* 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
--- 3374,3400 ----
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;
+ }
+ 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);
--- 3439,3465 ----
{
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 ****
--- 3483,3489 ----
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);
}
--- 3628,3656 ----
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
! 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 ****
--- 5803,5816 ----
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))
+ {
+ 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 ****
--- 7014,7023 ----
/* 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 ****
--- 7053,7070 ----
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
{
--- 7284,7296 ----
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
{
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.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-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,1770 ----
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)
! 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);
}
--- 4262,4276 ----
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_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;
--- 8223,8228 ----
*************** 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;
--- 8411,8417 ----
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,
--- 8428,8439 ----
{
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;
--- 8479,8485 ----
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 ****
--- 8492,8509 ----
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.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/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. */
\f
*************** 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/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_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/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: 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];\
}
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-01 18:17 ` Paul Richard Thomas
@ 2017-07-04 21:04 ` Thomas Koenig
2017-07-06 12:22 ` Paul Richard Thomas
2017-07-09 18:43 ` Paul Richard Thomas
0 siblings, 2 replies; 15+ messages in thread
From: Thomas Koenig @ 2017-07-04 21:04 UTC (permalink / raw)
To: Paul Richard Thomas, fortran, gcc-patches
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
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-04 21:04 ` Thomas Koenig
@ 2017-07-06 12:22 ` Paul Richard Thomas
2017-07-09 18:43 ` Paul Richard Thomas
1 sibling, 0 replies; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-06 12:22 UTC (permalink / raw)
To: Thomas Koenig, fortran
Hi Thomas,
I started working on this issue after I tried your earlier testcase.
There is indeed a temporary being produced that should not be there.
Since the whole point of the patch is to prevent this from happening,
I set to work immediately. The fix is straightforward but it causes
some regressions. I will resubmit asap.
Thanks
Paul
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
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-04 21:04 ` Thomas Koenig
2017-07-06 12:22 ` Paul Richard Thomas
@ 2017-07-09 18:43 ` Paul Richard Thomas
2017-07-09 21:28 ` Thomas Koenig
2017-09-11 19:47 ` H.J. Lu
1 sibling, 2 replies; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-09 18:43 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
[-- Attachment #1: Type: text/plain, Size: 7693 bytes --]
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
[-- Attachment #2: newsubmission.diff --]
[-- Type: text/plain, Size: 66228 bytes --]
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. */
\f
*************** 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];\
}
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-09 18:43 ` Paul Richard Thomas
@ 2017-07-09 21:28 ` Thomas Koenig
2017-07-11 6:16 ` Paul Richard Thomas
2017-09-11 19:47 ` H.J. Lu
1 sibling, 1 reply; 15+ messages in thread
From: Thomas Koenig @ 2017-07-09 21:28 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
Hi Paul,
> Please find attached what I believe is the final version of the patch.
This is looking very good, this does work as advertised and has
all the corner cases coverd.
I also regtested this on powerpc64-unknown-linux-gnu.
> 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.
Excellent!
> A possible final tweak - as asked before, should I bump up the module
> version number? My inclination is to say that we should.
Because we are changing the array descriptor (and thus binary
compatibility), we have to change the library version in
libtool-version. Bumping the module version should be done,
too.
> Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
So, OK from my side, with a bump in library and module version.
Maybe you could wait a couple of days before committing to give
others a chance to also test the patch.
Thanks a lot for finally making gfortran F95-compliant!
Regards
Thomas
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-09 21:28 ` Thomas Koenig
@ 2017-07-11 6:16 ` Paul Richard Thomas
2017-07-11 14:24 ` Paul Richard Thomas
0 siblings, 1 reply; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-11 6:16 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
Dear All,
We are not quite there yet. Thanks to the posters to the thread on
clf, I have now been convinced that ptr => der_type_array%comp must
return an lbound=1 based descriptor, since the target is not a WHOLE
ARRAY as defined in the standard. In addition, Dominique picked up a
failing testcase with -m32 for which he provided a fix.
I should re-re-re-submit tonight :-)
Paul
On 9 July 2017 at 22:27, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Paul,
>
>> Please find attached what I believe is the final version of the patch.
>
>
> This is looking very good, this does work as advertised and has
> all the corner cases coverd.
>
> I also regtested this on powerpc64-unknown-linux-gnu.
>
>> 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.
>
>
> Excellent!
>
>> A possible final tweak - as asked before, should I bump up the module
>> version number? My inclination is to say that we should.
>
>
> Because we are changing the array descriptor (and thus binary
> compatibility), we have to change the library version in
> libtool-version. Bumping the module version should be done,
> too.
>
>> Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
>
>
> So, OK from my side, with a bump in library and module version.
>
> Maybe you could wait a couple of days before committing to give
> others a chance to also test the patch.
>
> Thanks a lot for finally making gfortran F95-compliant!
>
> Regards
>
> Thomas
>
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-11 6:16 ` Paul Richard Thomas
@ 2017-07-11 14:24 ` Paul Richard Thomas
2017-07-11 14:48 ` Jerry DeLisle
0 siblings, 1 reply; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-11 14:24 UTC (permalink / raw)
To: Thomas Koenig; +Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
[-- Attachment #1: Type: text/plain, Size: 71469 bytes --]
Well, a bit earlier than anticipated, here is the final version that
puts right all the wrinkles that I know about.
Bootstraps and regtests - OK for trunk?
Paul
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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,8441 ****
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;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type
== BT_CLASS)
{
--- 8412,8435 ----
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;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
}
+
+ if (remap == NULL)
+ {
+ /* Is the target a whole array? If not, remap will
+ be non-null. */
+ for (remap = expr2->ref; remap; remap = remap->next)
+ if (remap->type == REF_ARRAY
+ && remap->u.ar.type == AR_FULL
+ && remap->next)
+ break;
+ }
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type
== BT_CLASS)
{
*************** 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,
--- 8440,8451 ----
{
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;
--- 8491,8497 ----
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 ****
--- 8504,8521 ----
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);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8586,8597 ****
{
gfc_se lbound_se;
- gcc_assert (remap->u.ar.start[dim]);
gcc_assert (!remap->u.ar.end[dim]);
gfc_init_se (&lbound_se, NULL);
! gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
!
! gfc_add_block_to_block (&block, &lbound_se.pre);
gfc_conv_shift_descriptor_lbound (&block, desc,
dim, lbound_se.expr);
gfc_add_block_to_block (&block, &lbound_se.post);
--- 8597,8611 ----
{
gfc_se lbound_se;
gcc_assert (!remap->u.ar.end[dim]);
gfc_init_se (&lbound_se, NULL);
! if (remap->u.ar.start[dim])
! {
! gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
! gfc_add_block_to_block (&block, &lbound_se.pre);
! }
! else
! lbound_se.expr = gfc_index_one_node;
gfc_conv_shift_descriptor_lbound (&block, desc,
dim, lbound_se.expr);
gfc_add_block_to_block (&block, &lbound_se.post);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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=c_intptr_t) :: 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=c_intptr_t) :: 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,81 ----
+ ! { 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
+ if (lbound (cptr, 1) .ne. 1) Call abort ! Not a whole array target!
+
+ 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(2) .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(2) .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: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 250082)
--- 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];\
}
On 11 July 2017 at 07:16, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> We are not quite there yet. Thanks to the posters to the thread on
> clf, I have now been convinced that ptr => der_type_array%comp must
> return an lbound=1 based descriptor, since the target is not a WHOLE
> ARRAY as defined in the standard. In addition, Dominique picked up a
> failing testcase with -m32 for which he provided a fix.
>
> I should re-re-re-submit tonight :-)
>
> Paul
>
>
> On 9 July 2017 at 22:27, Thomas Koenig <tkoenig@netcologne.de> wrote:
>> Hi Paul,
>>
>>> Please find attached what I believe is the final version of the patch.
>>
>>
>> This is looking very good, this does work as advertised and has
>> all the corner cases coverd.
>>
>> I also regtested this on powerpc64-unknown-linux-gnu.
>>
>>> 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.
>>
>>
>> Excellent!
>>
>>> A possible final tweak - as asked before, should I bump up the module
>>> version number? My inclination is to say that we should.
>>
>>
>> Because we are changing the array descriptor (and thus binary
>> compatibility), we have to change the library version in
>> libtool-version. Bumping the module version should be done,
>> too.
>>
>>> Bootstrapped and regtested on FC23/x86_64 - OK for trunk?
>>
>>
>> So, OK from my side, with a bump in library and module version.
>>
>> Maybe you could wait a couple of days before committing to give
>> others a chance to also test the patch.
>>
>> Thanks a lot for finally making gfortran F95-compliant!
>>
>> Regards
>>
>> Thomas
>>
>
>
>
> --
> "If you can't explain it simply, you don't understand it well enough"
> - Albert Einstein
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 67715 bytes --]
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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,8441 ****
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;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
--- 8412,8435 ----
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;
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
NULL, NULL);
}
+
+ if (remap == NULL)
+ {
+ /* Is the target a whole array? If not, remap will
+ be non-null. */
+ for (remap = expr2->ref; remap; remap = remap->next)
+ if (remap->type == REF_ARRAY
+ && remap->u.ar.type == AR_FULL
+ && remap->next)
+ break;
+ }
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
*************** 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,
--- 8440,8451 ----
{
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;
--- 8491,8497 ----
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 ****
--- 8504,8521 ----
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);
*************** gfc_trans_pointer_assignment (gfc_expr *
*** 8586,8597 ****
{
gfc_se lbound_se;
- gcc_assert (remap->u.ar.start[dim]);
gcc_assert (!remap->u.ar.end[dim]);
gfc_init_se (&lbound_se, NULL);
! gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
!
! gfc_add_block_to_block (&block, &lbound_se.pre);
gfc_conv_shift_descriptor_lbound (&block, desc,
dim, lbound_se.expr);
gfc_add_block_to_block (&block, &lbound_se.post);
--- 8597,8611 ----
{
gfc_se lbound_se;
gcc_assert (!remap->u.ar.end[dim]);
gfc_init_se (&lbound_se, NULL);
! if (remap->u.ar.start[dim])
! {
! gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
! gfc_add_block_to_block (&block, &lbound_se.pre);
! }
! else
! lbound_se.expr = gfc_index_one_node;
gfc_conv_shift_descriptor_lbound (&block, desc,
dim, lbound_se.expr);
gfc_add_block_to_block (&block, &lbound_se.post);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c (revision 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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. */
\f
*************** 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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 250082)
--- 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=c_intptr_t) :: 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=c_intptr_t) :: 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,81 ----
+ ! { 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
+ if (lbound (cptr, 1) .ne. 1) Call abort ! Not a whole array target!
+
+ 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(2) .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(2) .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: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 250082)
--- 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];\
}
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-11 14:24 ` Paul Richard Thomas
@ 2017-07-11 14:48 ` Jerry DeLisle
2017-07-11 18:13 ` Thomas Koenig
0 siblings, 1 reply; 15+ messages in thread
From: Jerry DeLisle @ 2017-07-11 14:48 UTC (permalink / raw)
To: Paul Richard Thomas, Thomas Koenig
Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
On 07/11/2017 07:23 AM, Paul Richard Thomas wrote:
> Well, a bit earlier than anticipated, here is the final version that
> puts right all the wrinkles that I know about.
>
> Bootstraps and regtests - OK for trunk?
>
> Paul
Somewhere in the threads on this, there was mentioned ABI breakage/change.
Does it really do this? If the significant change is in the descriptor and you
just added the span on the end of the structure, I am not convinced this is an
issue. (I have not studied the patch at all, I would rather not bump library
version)
Jerry
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-11 14:48 ` Jerry DeLisle
@ 2017-07-11 18:13 ` Thomas Koenig
2017-07-11 20:23 ` Paul Richard Thomas
0 siblings, 1 reply; 15+ messages in thread
From: Thomas Koenig @ 2017-07-11 18:13 UTC (permalink / raw)
To: Jerry DeLisle, Paul Richard Thomas
Cc: fortran, gcc-patches, Damian Rouson, Bader, Reinhold
Am 11.07.2017 um 16:48 schrieb Jerry DeLisle:
> Somewhere in the threads on this, there was mentioned ABI breakage/change.
That was me.
> Does it really do this?
Yes. Look at this part:
Index: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 250082)
--- 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];\
}
> If the significant change is in the descriptor and you
> just added the span on the end of the structure, I am not convinced
this is an
> issue. (I have not studied the patch at all, I would rather not bump
library
> version)
Unless I am mistaken, we only build the required dimensions for
an array descriptor. Putting it on the end would not work
unless we changed that behavior.
But we are doing something wrong with the array descriptors anyway. See
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=68649#c7 for a description.
Other comments in the same PR have some suggestions, but nothing that
works (or so I think).
So, if we do break the ABI, we could try to fix the remaining
issues with the array descriptors - not with this patch, but
before 8.1 is released. Flexible array members come to mind.
Regards
Thomas
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-11 18:13 ` Thomas Koenig
@ 2017-07-11 20:23 ` Paul Richard Thomas
0 siblings, 0 replies; 15+ messages in thread
From: Paul Richard Thomas @ 2017-07-11 20:23 UTC (permalink / raw)
To: Thomas Koenig
Cc: Jerry DeLisle, fortran, gcc-patches, Damian Rouson, Bader, Reinhold
Hi Jerry and Thomas,
As Thomas noted, the span field is added in the middle of the
descriptor because the caf token field makes the descriptor variable
length. This is reflected in the change in libgfortran.h.
It has crossed my mind in the last twenty four hours that I should add
some more fields, for example by expanding the dtype field, which
would then allow us to bump up the maximum number of dimensions for
example.
However, I seem, temporarily I hope, to be completely blown out of the
water. We had a rainstorm this afternoon, which caused a glitch in the
mains. Now, neither of my workstations seem to work any more. I have
tried everything but both remain totally unresponsive.
As to anything to do with lto, I am sorry but it is beyond my pay
grade. I got caught with lto in implementing the submodule patch. I
got lucky in that I found the fix more or less by trying things at
random. That said, I'll take a look at p68649 once my blood pressure
has dropped. It seems to me that the gurus have provided more than
enough clues.
Regards
Paul
On 11 July 2017 at 19:12, Thomas Koenig <tkoenig@netcologne.de> wrote:
> Am 11.07.2017 um 16:48 schrieb Jerry DeLisle:
>
>> Somewhere in the threads on this, there was mentioned ABI breakage/change.
>
>
> That was me.
>
>> Does it really do this?
>
>
> Yes. Look at this part:
>
> Index: libgfortran/libgfortran.h
> ===================================================================
> *** libgfortran/libgfortran.h (revision 250082)
> --- 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];\
> }
>
>> If the significant change is in the descriptor and you
>> just added the span on the end of the structure, I am not convinced this
>> is an
>> issue. (I have not studied the patch at all, I would rather not bump
>> library
>> version)
>
> Unless I am mistaken, we only build the required dimensions for
> an array descriptor. Putting it on the end would not work
> unless we changed that behavior.
>
> But we are doing something wrong with the array descriptors anyway. See
> https://gcc.gnu.org/bugzilla/show_bug.cgi?id=68649#c7 for a description.
> Other comments in the same PR have some suggestions, but nothing that
> works (or so I think).
>
> So, if we do break the ABI, we could try to fix the remaining
> issues with the array descriptors - not with this patch, but
> before 8.1 is released. Flexible array members come to mind.
>
> Regards
>
> Thomas
--
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
2017-07-09 18:43 ` Paul Richard Thomas
2017-07-09 21:28 ` Thomas Koenig
@ 2017-09-11 19:47 ` H.J. Lu
1 sibling, 0 replies; 15+ messages in thread
From: H.J. Lu @ 2017-09-11 19:47 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Thomas Koenig, fortran, gcc-patches, Damian Rouson, Bader, Reinhold
On Sun, Jul 9, 2017 at 11:43 AM, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> 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.
>
This caused:
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=82184
--
H.J.
^ permalink raw reply [flat|nested] 15+ messages in thread
* Re: [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer
@ 2017-07-10 13:51 Dominique d'Humières
0 siblings, 0 replies; 15+ messages in thread
From: Dominique d'Humières @ 2017-07-10 13:51 UTC (permalink / raw)
To: pault at gcc dot gnu.org; +Cc: Thomas Koenig, gfortran
Dear Paul,
The new patch passes all my tests but gfortran.dg/pointer_array_7.f90 with -m32. The following instrumented test
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)
print *, 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)
print *, s1
! if (s1 /= s3) call abort
s2 = transfer(c_loc(pc(2)),s2)
print *, s2
if (s2 /= s3) call abort
end program main
gives at run time
140734725288716
140734725288716
140734725288716
with -m64, but
3220395052
-6820988759585893332
-6820989146132949972
Program aborted. Backtrace:
…
with -m32.
TIA
Dominique
^ permalink raw reply [flat|nested] 15+ messages in thread
end of thread, other threads:[~2017-09-11 19:47 UTC | newest]
Thread overview: 15+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-06-24 10:48 [Patch, fortran] PR34640 - ICE when assigning item of a derived-component to a pointer Paul Richard Thomas
2017-06-25 10:59 ` Thomas Koenig
2017-06-25 11:43 ` Paul Richard Thomas
2017-07-01 18:17 ` Paul Richard Thomas
2017-07-04 21:04 ` Thomas Koenig
2017-07-06 12:22 ` Paul Richard Thomas
2017-07-09 18:43 ` Paul Richard Thomas
2017-07-09 21:28 ` Thomas Koenig
2017-07-11 6:16 ` Paul Richard Thomas
2017-07-11 14:24 ` Paul Richard Thomas
2017-07-11 14:48 ` Jerry DeLisle
2017-07-11 18:13 ` Thomas Koenig
2017-07-11 20:23 ` Paul Richard Thomas
2017-09-11 19:47 ` H.J. Lu
2017-07-10 13:51 Dominique d'Humières
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).