re PR fortran/34640 (ICE when assigning item of a derived-component to a pointer)
2017-09-10 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. In the case that the target is not a whole array, use the target array ref for remap and, since the 'start' indices are missing, set the lbounds to one, as required by the standard. * 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-09-10 Paul Thomas <pault@gcc.gnu.org> PR fortran/34640 * gfortran.dg/associate_24.f90: New test. * 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. 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-09-10 Paul Thomas <pault@gcc.gnu.org> PR fortran/34640 * libgfortran/libgfortran.h: Add span field to descriptor. * libgfortran/libtool-version : Bump up version number to 5:0:0. From-SVN: r251949
This commit is contained in:
Paul Thomas
parent
7368cfa498
commit
ff3598bc73
|
|
@ -1,3 +1,68 @@
|
|||
2017-09-10 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. In the case
|
||||
that the target is not a whole array, use the target array ref
|
||||
for remap and, since the 'start' indices are missing, set the
|
||||
lbounds to one, as required by the standard.
|
||||
* 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-09-09 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
* decl.c : Add decl_type_param_list, type_param_spec_list as
|
||||
|
|
|
|||
|
|
@ -995,6 +995,11 @@ is_subref_array (gfc_expr * e)
|
|||
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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -125,8 +125,9 @@ gfc_array_dataptr_type (tree desc)
|
|||
#define DATA_FIELD 0
|
||||
#define OFFSET_FIELD 1
|
||||
#define DTYPE_FIELD 2
|
||||
#define DIMENSION_FIELD 3
|
||||
#define CAF_TOKEN_FIELD 4
|
||||
#define SPAN_FIELD 3
|
||||
#define DIMENSION_FIELD 4
|
||||
#define CAF_TOKEN_FIELD 5
|
||||
|
||||
#define STRIDE_SUBFIELD 0
|
||||
#define LBOUND_SUBFIELD 1
|
||||
|
|
@ -244,6 +245,36 @@ gfc_conv_descriptor_dtype (tree desc)
|
|||
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)
|
||||
|
|
@ -466,11 +497,41 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
|
|||
}
|
||||
|
||||
|
||||
/* 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
|
||||
|
|
@ -720,6 +781,84 @@ gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
|
|||
}
|
||||
|
||||
|
||||
/* 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
|
||||
|
|
@ -3239,11 +3378,30 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
|
|||
index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
||||
index, info->offset);
|
||||
|
||||
if (expr && (is_subref_array (expr)
|
||||
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
|
||||
|
|
@ -3288,45 +3446,27 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
|
|||
{
|
||||
tree tmp;
|
||||
tree type;
|
||||
tree cdecl;
|
||||
bool classarray = false;
|
||||
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)))
|
||||
cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
|
||||
cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
|
||||
TREE_OPERAND (desc, 0)));
|
||||
else
|
||||
cdecl = desc;
|
||||
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 (cdecl))
|
||||
&& TREE_CODE (cdecl) == COMPONENT_REF)
|
||||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
|
||||
&& TREE_CODE (cdesc) == COMPONENT_REF)
|
||||
{
|
||||
type = TREE_TYPE (TREE_OPERAND (cdecl, 0));
|
||||
type = TREE_TYPE (TREE_OPERAND (cdesc, 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;
|
||||
vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
|
||||
}
|
||||
|
||||
tmp = gfc_conv_array_data (desc);
|
||||
|
|
@ -3350,6 +3490,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
|
|||
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;
|
||||
|
|
@ -3494,8 +3635,31 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
|
|||
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);
|
||||
/* 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);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -5651,6 +5815,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
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)
|
||||
{
|
||||
|
|
@ -6854,6 +7031,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
|
|||
/* 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)
|
||||
{
|
||||
|
|
@ -6889,8 +7070,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
|
|||
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;
|
||||
}
|
||||
|
|
@ -7110,9 +7301,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
|
|||
desc = info->descriptor;
|
||||
if (se->direct_byref && !se->byref_noassign)
|
||||
{
|
||||
/* For pointer assignments we fill in the destination. */
|
||||
/* 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
|
||||
{
|
||||
|
|
@ -7585,6 +7780,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
|
|||
/* 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),
|
||||
|
|
|
|||
|
|
@ -156,9 +156,13 @@ tree gfc_conv_array_ubound (tree, int);
|
|||
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);
|
||||
|
|
@ -169,6 +173,7 @@ tree gfc_conv_descriptor_token (tree);
|
|||
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -1532,6 +1532,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
/* 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)
|
||||
{
|
||||
|
|
@ -1766,27 +1769,18 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
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;
|
||||
if (sym->assoc && sym->attr.subref_array_pointer)
|
||||
sym->attr.pointer = 1;
|
||||
|
||||
GFC_DECL_SPAN (decl) = span;
|
||||
GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
|
||||
}
|
||||
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;
|
||||
GFC_DECL_CLASS(decl) = 1;
|
||||
|
||||
sym->backend_decl = decl;
|
||||
|
||||
|
|
@ -4347,13 +4341,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
|
|||
}
|
||||
}
|
||||
|
||||
if (sym->attr.subref_array_pointer
|
||||
&& GFC_DECL_SPAN (sym->backend_decl)
|
||||
&& !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
|
||||
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_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
|
||||
build_int_cst (gfc_array_index_type, 0));
|
||||
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -5413,7 +5413,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
|||
}
|
||||
|
||||
if (e->expr_type == EXPR_VARIABLE
|
||||
&& is_subref_array (e))
|
||||
&& 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
|
||||
|
|
@ -8223,7 +8224,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
stmtblock_t block;
|
||||
tree desc;
|
||||
tree tmp;
|
||||
tree decl;
|
||||
bool scalar, non_proc_pointer_assign;
|
||||
gfc_ss *ss;
|
||||
|
||||
|
|
@ -8412,30 +8412,24 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
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)
|
||||
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)
|
||||
{
|
||||
/* If the target is not a whole array, use the target array
|
||||
reference for remap. */
|
||||
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)
|
||||
{
|
||||
|
|
@ -8446,7 +8440,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
{
|
||||
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,
|
||||
|
|
@ -8492,7 +8491,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
converted in rse and now have to build the correct LHS
|
||||
descriptor for it. */
|
||||
|
||||
tree dtype, data;
|
||||
tree dtype, data, span;
|
||||
tree offs, stride;
|
||||
tree lbound, ubound;
|
||||
|
||||
|
|
@ -8505,6 +8504,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
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);
|
||||
|
|
@ -8586,12 +8597,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|||
{
|
||||
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);
|
||||
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
|
||||
/* This remap arises from a target that is not a whole
|
||||
array. The start expressions will be NULL but we need
|
||||
the lbounds to be one. */
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -1225,10 +1225,9 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
|
|||
&& 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 */);
|
||||
/* 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));
|
||||
|
|
@ -8129,6 +8128,11 @@ conv_isocbinding_subroutine (gfc_code *code)
|
|||
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));
|
||||
|
|
|
|||
|
|
@ -2569,6 +2569,12 @@ gfc_trans_transfer (gfc_code * code)
|
|||
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
|
||||
|
|
@ -2603,6 +2609,7 @@ gfc_trans_transfer (gfc_code * code)
|
|||
goto finish_block_label;
|
||||
}
|
||||
|
||||
scalarize:
|
||||
/* Initialize the scalarizer. */
|
||||
ss = gfc_walk_expr (expr);
|
||||
gfc_init_loopinfo (&loop);
|
||||
|
|
@ -2618,7 +2625,9 @@ gfc_trans_transfer (gfc_code * code)
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1531,6 +1531,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
|||
int n;
|
||||
tree charlen;
|
||||
bool need_len_assign;
|
||||
bool whole_array = true;
|
||||
gfc_ref *ref;
|
||||
|
||||
gcc_assert (sym->assoc);
|
||||
e = sym->assoc->target;
|
||||
|
|
@ -1541,6 +1543,15 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
|||
|
||||
unlimited = UNLIMITED_POLY (e);
|
||||
|
||||
for (ref = e->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY
|
||||
&& ref->u.ar.type == AR_FULL
|
||||
&& ref->next)
|
||||
{
|
||||
whole_array = false;
|
||||
break;
|
||||
}
|
||||
|
||||
/* Assignments to the string length need to be generated, when
|
||||
( sym is a char array or
|
||||
sym has a _len component)
|
||||
|
|
@ -1583,11 +1594,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
|||
|
||||
/* If we didn't already do the pointer assignment, set associate-name
|
||||
descriptor to the one generated for the temporary. */
|
||||
if (!sym->assoc->variable && !cst_array_ctor)
|
||||
if ((!sym->assoc->variable && !cst_array_ctor)
|
||||
|| !whole_array)
|
||||
{
|
||||
int dim;
|
||||
|
||||
gfc_add_modify (&se.pre, desc, se.expr);
|
||||
if (whole_array)
|
||||
gfc_add_modify (&se.pre, desc, se.expr);
|
||||
|
||||
/* The generated descriptor has lower bound zero (as array
|
||||
temporary), shift bounds so we get lower bounds of 1. */
|
||||
|
|
@ -1606,7 +1619,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
|||
: 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);
|
||||
gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
|
||||
}
|
||||
|
||||
/* Done, register stuff as init / cleanup code. */
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see
|
|||
#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. */
|
||||
#include "attribs.h"
|
||||
|
||||
|
|
@ -1786,6 +1787,12 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
|
|||
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)
|
||||
{
|
||||
|
|
@ -2715,6 +2722,11 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
|
|||
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)
|
||||
|
|
@ -3154,7 +3166,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
|
|||
{
|
||||
int rank, dim;
|
||||
bool indirect = false;
|
||||
tree etype, ptype, field, t, base_decl;
|
||||
tree etype, ptype, t, base_decl;
|
||||
tree data_off, dim_off, dtype_off, dim_size, elem_size;
|
||||
tree lower_suboff, upper_suboff, stride_suboff;
|
||||
|
||||
|
|
@ -3211,24 +3223,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
|
|||
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);
|
||||
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))
|
||||
|
|
|
|||
|
|
@ -305,6 +305,67 @@ gfc_build_addr_expr (tree type, tree t)
|
|||
}
|
||||
|
||||
|
||||
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_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
|
||||
&& (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|
||||
|| TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
|
||||
&& (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
|
||||
|| TREE_CODE (decl) == FUNCTION_DECL
|
||||
|| DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|
||||
== DECL_CONTEXT (decl)))
|
||||
{
|
||||
span = TYPE_MAX_VALUE (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
|
||||
|
|
@ -312,7 +373,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
|
|||
{
|
||||
tree type = TREE_TYPE (base);
|
||||
tree tmp;
|
||||
tree span;
|
||||
tree span = NULL_TREE;
|
||||
|
||||
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
|
||||
{
|
||||
|
|
@ -331,77 +392,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
|
|||
|
||||
type = TREE_TYPE (type);
|
||||
|
||||
/* Use pointer arithmetic for deferred character length array
|
||||
references. */
|
||||
if (type && TREE_CODE (type) == ARRAY_TYPE
|
||||
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
|
||||
&& (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|
||||
|| TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF)
|
||||
&& decl
|
||||
&& (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF
|
||||
|| TREE_CODE (decl) == FUNCTION_DECL
|
||||
|| (DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))
|
||||
== DECL_CONTEXT (decl))))
|
||||
span = TYPE_MAX_VALUE (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 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)
|
||||
{
|
||||
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);
|
||||
|
|
@ -412,8 +419,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
|
|||
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
||||
return tmp;
|
||||
}
|
||||
/* Otherwise use a straightforward array reference. */
|
||||
else
|
||||
/* Otherwise use a straightforward array reference. */
|
||||
return build4_loc (input_location, ARRAY_REF, type, base, offset,
|
||||
NULL_TREE, NULL_TREE);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -982,7 +982,7 @@ struct GTY(()) lang_decl {
|
|||
#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_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)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,31 @@
|
|||
2017-09-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/34640
|
||||
* gfortran.dg/associate_24.f90: New test.
|
||||
* 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.
|
||||
|
||||
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-09-09 Jonathan Wakely <jwakely@redhat.com>
|
||||
|
||||
PR c++/81852
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! From posting by Spectrum to clf on thread entitled "Bounds for array pointer dummy argument".
|
||||
!
|
||||
PROGRAM X
|
||||
implicit none
|
||||
TYPE T
|
||||
INTEGER :: I
|
||||
END TYPE T
|
||||
TYPE(T), TARGET :: T1( 0:3 )
|
||||
|
||||
associate( P => T1 % I )
|
||||
call check (lbound (P, 1), ubound (P, 1) ,1 , 4)
|
||||
endassociate
|
||||
|
||||
associate( P2 => T1(:) % I )
|
||||
call check (lbound (P2, 1), ubound (P2, 1) ,1 , 4)
|
||||
endassociate
|
||||
|
||||
associate( Q => T1 )
|
||||
call check (lbound (Q, 1), ubound (Q, 1) ,0 , 3)
|
||||
endassociate
|
||||
|
||||
associate( Q2 => T1(:) )
|
||||
call check (lbound (Q2, 1), ubound (Q2, 1) ,1 , 4)
|
||||
endassociate
|
||||
contains
|
||||
subroutine check (lbnd, ubnd, lower, upper)
|
||||
integer :: lbnd, ubnd, lower, upper
|
||||
if (lbnd .ne. lower) call abort
|
||||
if (ubnd .ne. upper) call abort
|
||||
end subroutine
|
||||
END PROGRAM X
|
||||
|
|
@ -151,9 +151,9 @@ end
|
|||
! { 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 .\\(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.0:. .\\) array_t3_ptr.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" } }
|
||||
|
||||
|
|
|
|||
|
|
@ -16,5 +16,5 @@ program main
|
|||
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" } }
|
||||
! { 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" } }
|
||||
|
|
|
|||
|
|
@ -133,9 +133,9 @@ end
|
|||
! { 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 .\\(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.0:. .\\) array_t3_ptr.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" } }
|
||||
|
||||
|
|
|
|||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -0,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
|
||||
|
|
@ -1,3 +1,9 @@
|
|||
2017-09-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/34640
|
||||
* libgfortran/libgfortran.h: Add span field to descriptor.
|
||||
* libgfortran/libtool-version : Bump up version number to 5:0:0.
|
||||
|
||||
2017-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/78387
|
||||
|
|
|
|||
|
|
@ -339,6 +339,7 @@ struct {\
|
|||
type *base_addr;\
|
||||
size_t offset;\
|
||||
index_type dtype;\
|
||||
index_type span;\
|
||||
descriptor_dimension dim[r];\
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@
|
|||
# This is a separate file so that version updates don't involve re-running
|
||||
# automake.
|
||||
# CURRENT:REVISION:AGE
|
||||
4:0:0
|
||||
5:0:0
|
||||
|
|
|
|||
Loading…
Reference in New Issue