+2007-09-16 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/29396
+ PR fortran/29606
+ PR fortran/30625
+ PR fortran/30871
+ * trans.h : Add extra argument to gfc_build_array_ref. Rename
+ gfc_conv_aliased_arg to gfc_conv_subref_array_arg. Move
+ prototype of is_aliased_array to gfortran.h and rename it
+ gfc_is_subref_array. Add field span to lang_decl, add a new
+ decl lang specific flag accessed by GFC_DECL_SUBREF_ARRAY_P
+ and a new type flag GFC_DECL_SUBREF_ARRAY_P.
+ * trans.c (gfc_build_array_ref): Add the new argument, decl.
+ If this is a subreference array pointer, use the lang_decl
+ field 'span' to calculate the offset in bytes and use pointer
+ arithmetic to address the element.
+ * trans-array.c (gfc_conv_scalarized_array_ref,
+ gfc_conv_array_ref): Add the backend declaration as the third
+ field, if it is likely to be a subreference array pointer.
+ (gfc_conv_descriptor_dimension, gfc_trans_array_ctor_element,
+ gfc_trans_array_constructor_element, structure_alloc_comps,
+ gfc_conv_array_index_offset): For all other references to
+ gfc_build_array_ref, set the third argument to NULL.
+ (gfc_get_dataptr_offset): New function.
+ (gfc_conv_expr_descriptor): If the rhs of a pointer assignment
+ is a subreference array, then calculate the offset to the
+ subreference of the first element and set the descriptor data
+ pointer to this, using gfc_get_dataptr_offset.
+ trans-expr.c (gfc_get_expr_charlen): Use the expression for the
+ character length for a character subreference.
+ (gfc_conv_substring, gfc_conv_subref_array_arg): Add NULL for
+ third argument in call to gfc_build_array_ref.
+ (gfc_conv_aliased_arg): Rename to gfc_conv_subref_array_arg.
+ (is_aliased_array): Remove.
+ (gfc_conv_function_call): Change reference to is_aliased_array
+ to gfc_is_subref_array and reference to gfc_conv_aliased_arg to
+ gfc_conv_subref_array_arg.
+ (gfc_trans_pointer_assignment): Add the array element length to
+ the lang_decl 'span' field.
+ * gfortran.h : Add subref_array_pointer to symbol_attribute and
+ add the prototype for gfc_is_subref_array.
+ * trans-stmt.c : Add NULL for third argument in all references
+ to gfc_build_array_ref.
+ * expr.c (gfc_is_subref_array): Renamed is_aliased_array.
+ If this is a subreference array pointer, return true.
+ (gfc_check_pointer_assign): If the rhs is a subreference array,
+ set the lhs subreference_array_pointer attribute.
+ * trans-decl.c (gfc_get_symbol_decl): Allocate the lang_decl
+ field if the symbol is a subreference array pointer and set an
+ initial value of zero for the 'span' field.
+ * trans-io.c (set_internal_unit): Refer to is_subref_array and
+ gfc_conv_subref_array_arg.
+ (nml_get_addr_expr): Add NULL third argument to
+ gfc_build_array_ref.
+ (gfc_trans_transfer): Use the scalarizer for a subreference
+ array.
+
2007-09-13 Thomas Koenig <tkoenig@gcc.gnu.org>
* iresolve.c (resolve_mask_arg): If a mask is an array
}
+/* Is true if an array reference is followed by a component or substring
+ reference. */
+bool
+is_subref_array (gfc_expr * e)
+{
+ gfc_ref * ref;
+ bool seen_array;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (e->symtree->n.sym->attr.subref_array_pointer)
+ return true;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
+
+ if (seen_array
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+}
+
+
/* Try to collapse intrinsic expressions. */
static try
return FAILURE;
}
+ if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
- implied_index:1;
+ implied_index:1, subref_array_pointer:1;
ENUM_BITFIELD (save_state) save:2;
gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *);
const char *gfc_extract_int (gfc_expr *, int *);
gfc_expr *gfc_expr_to_initialize (gfc_expr *);
+bool is_subref_array (gfc_expr *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim);
+ tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
/* Store the value. */
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
- tmp = gfc_build_array_ref (tmp, offset);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, *poffset);
+ tmp = gfc_build_array_ref (tmp, *poffset, NULL);
tmp = build_fold_addr_expr (tmp);
init = build_fold_addr_expr (init);
/* Read the vector to get an index into info->descriptor. */
data = build_fold_indirect_ref (gfc_conv_array_data (desc));
- index = gfc_build_array_ref (data, index);
+ index = gfc_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
/* Do any bounds checking on the final info->descriptor index. */
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
gfc_ss_info *info;
+ tree decl = NULL_TREE;
tree index;
tree tmp;
int n;
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
+ if (se->ss->expr && is_subref_array (se->ss->expr))
+ decl = se->ss->expr->symtree->n.sym->backend_decl;
+
tmp = build_fold_indirect_ref (info->data);
- se->expr = gfc_build_array_ref (tmp, index);
+ se->expr = gfc_build_array_ref (tmp, index, decl);
}
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
-
+
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, index);
+ se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}
}
+/* Calculate the overall offset, including subreferences. */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+ bool subref, gfc_expr *expr)
+{
+ tree tmp;
+ tree field;
+ tree stride;
+ tree index;
+ gfc_ref *ref;
+ gfc_se start;
+ int n;
+
+ /* If offset is NULL and this is not a subreferenced array, there is
+ nothing to do. */
+ if (offset == NULL_TREE)
+ {
+ if (subref)
+ offset = gfc_index_zero_node;
+ else
+ return;
+ }
+
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+ /* Offset the data pointer for pointer assignments from arrays with
+ subreferences; eg. my_integer => my_type(:)%integer_component. */
+ if (subref)
+ {
+ /* Go past the array reference. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY &&
+ ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = ref->next;
+ break;
+ }
+
+ /* Calculate the offset for each subsequent subreference. */
+ for (; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ field = ref->u.c.component->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+ tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ break;
+
+ case REF_SUBSTRING:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+ gfc_add_block_to_block (block, &start.pre);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ break;
+
+ case REF_ARRAY:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+ && ref->u.ar.type == AR_ELEMENT);
+
+ /* TODO - Add bounds checking. */
+ stride = gfc_index_one_node;
+ index = gfc_index_zero_node;
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ tree itmp;
+ tree jtmp;
+
+ /* Update the index. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+ itmp = gfc_evaluate_now (start.expr, block);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+ jtmp = gfc_evaluate_now (start.expr, block);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
+ itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+ index = gfc_evaluate_now (index, block);
+
+ /* Update the stride. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
+ itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, itmp);
+ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ /* Apply the index to obtain the array element. */
+ tmp = gfc_build_array_ref (tmp, index, NULL);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+ }
+
+ /* Set the target data pointer. */
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
tree start;
tree offset;
int full;
+ bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
- need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+ subref_array_target = se->direct_byref && is_subref_array (expr);
+ need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+ && !subref_array_target;
+
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Copy the descriptor for pointer assignments. */
gfc_add_modify_expr (&se->pre, se->expr, desc);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+ subref_array_target, expr);
}
else if (se->want_pointer)
{
if (se->data_not_needed)
gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
else
- {
- /* Point the data pointer at the first element in the section. */
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, offset);
- offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
- gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
- }
+ /* Point the data pointer at the first element in the section. */
+ gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+ subref_array_target, expr);
if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
&& !se->data_not_needed)
/* Build the body of the loop. */
gfc_init_block (&loopbody);
- vref = gfc_build_array_ref (var, index);
+ vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP)
{
gfc_add_expr_to_block (&fnblock, tmp);
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
- dref = gfc_build_array_ref (tmp, index);
+ dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else
gcc_assert (!sym->value);
}
}
+ 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 (VAR_DECL, create_tmp_var_name ("span"),
+ gfc_array_index_type);
+ gfc_finish_var_decl (span, sym);
+ TREE_STATIC (span) = 1;
+ DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+
+ GFC_DECL_SPAN (decl) = span;
+ }
+
sym->backend_decl = decl;
if (sym->attr.assign)
length = NULL; /* To silence compiler warning. */
+ if (is_subref_array (e) && e->ts.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
+ e->ts.cl->backend_decl = tmpse.expr;
+ return tmpse.expr;
+ }
+
/* First candidate: if the variable is of type CHARACTER, the
expression's length could be the length of the character
variable. */
/* We should never got substring references here. These will be
broken down by the scalarizer. */
gcc_unreachable ();
+ break;
}
}
tmp = se->expr;
else
tmp = build_fold_indirect_ref (se->expr);
- tmp = gfc_build_array_ref (tmp, start.expr);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
se->expr = gfc_build_addr_expr (type, tmp);
}
gfc_free_expr (expr);
}
+
/* Returns a reference to a temporary array into which a component of
an actual argument derived type array is copied and then returned
- after the function call.
- TODO Get rid of this kludge, when array descriptors are capable of
- handling arrays with a bigger stride in bytes than size. */
-
+ after the function call. */
void
-gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
- int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
+ int g77, sym_intent intent)
{
gfc_se lse;
gfc_se rse;
/* Now use the offset for the reference. */
tmp = build_fold_indirect_ref (info->data);
- rse.expr = gfc_build_array_ref (tmp, tmp_index);
+ rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
rse.string_length = expr->ts.cl->backend_decl;
return;
}
-/* Is true if an array reference is followed by a component or substring
- reference. */
-
-bool
-is_aliased_array (gfc_expr * e)
-{
- gfc_ref * ref;
- bool seen_array;
-
- seen_array = false;
- for (ref = e->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
- seen_array = true;
-
- if (seen_array
- && ref->type != REF_ARRAY)
- return seen_array;
- }
- return false;
-}
/* Generate the code for argument list functions. */
f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
- && is_aliased_array (e))
+ && 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
written back after the procedure call. */
- gfc_conv_aliased_arg (&parmse, e, f,
+ gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
else
gfc_conv_array_parameter (&parmse, e, argss, f);
stmtblock_t block;
tree desc;
tree tmp;
+ tree decl;
+
gfc_start_block (&block);
/* Assign directly to the pointer's descriptor. */
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2, rss);
+
+ /* If this is a subreference array pointer assignment, use the rhs
+ element size for the lhs span. */
+ if (expr1->symtree->n.sym->attr.subref_array_pointer)
+ {
+ decl = expr1->symtree->n.sym->backend_decl;
+ tmp = rss->data.info.descriptor;
+ tmp = gfc_get_element_type (TREE_TYPE (tmp));
+ tmp = size_in_bytes (tmp);
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
+ }
+
break;
default:
{
se.ss = gfc_walk_expr (e);
- if (is_aliased_array (e))
+ if (is_subref_array (e))
{
/* Use a temporary for components of arrays of derived types
or substring array references. */
- gfc_conv_aliased_arg (&se, e, 0,
+ gfc_conv_subref_array_arg (&se, e, 0,
last_dt == READ ? INTENT_IN : INTENT_OUT);
tmp = build_fold_indirect_ref (se.expr);
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
a RECORD_TYPE. */
if (array_flagged)
- tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
+ tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
/* Now build the address expression. */
gcc_assert (ref->type == REF_ARRAY);
}
- if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
+ if (expr->ts.type != BT_DERIVED
+ && ref && ref->next == NULL
+ && !is_subref_array (expr))
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);
/* If a mask was specified make the assignment conditional. */
if (mask)
{
- tmp = gfc_build_array_ref (mask, maskindex);
+ tmp = gfc_build_array_ref (mask, maskindex, NULL);
body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
}
}
gfc_conv_expr (&lse, expr);
/* Form the expression for the temporary. */
- tmp = gfc_build_array_ref (tmp1, count1);
+ tmp = gfc_build_array_ref (tmp1, count1, NULL);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
- rse.expr = gfc_build_array_ref (tmp1, count1);
+ rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
- lse.expr = gfc_build_array_ref (tmp1, count1);
+ lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
- lse.expr = gfc_build_array_ref (tmp1, count1);
+ lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
/* Use the scalar assignment. */
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
- lse.expr = gfc_build_array_ref (tmp1, count);
+ lse.expr = gfc_build_array_ref (tmp1, count, NULL);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
- rse.expr = gfc_build_array_ref (tmp1, count);
+ rse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&body, &lse.pre);
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
- lse.expr = gfc_build_array_ref (tmp1, count);
+ lse.expr = gfc_build_array_ref (tmp1, count, NULL);
lse.direct_byref = 1;
rss = gfc_walk_expr (expr2);
gfc_conv_expr_descriptor (&lse, expr2, rss);
/* Reset count. */
gfc_add_modify_expr (block, count, gfc_index_zero_node);
- parm = gfc_build_array_ref (tmp1, count);
+ parm = gfc_build_array_ref (tmp1, count, NULL);
lss = gfc_walk_expr (expr1);
gfc_init_se (&lse, NULL);
gfc_conv_expr_descriptor (&lse, expr1, lss);
/* Store the mask. */
se.expr = convert (mask_type, se.expr);
- tmp = gfc_build_array_ref (mask, maskindex);
+ tmp = gfc_build_array_ref (mask, maskindex, NULL);
gfc_add_modify_expr (&body, tmp, se.expr);
/* Advance to the next mask element. */
if (mask && (cmask || pmask))
{
- tmp = gfc_build_array_ref (mask, count);
+ tmp = gfc_build_array_ref (mask, count, NULL);
if (invert)
tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
gfc_add_modify_expr (&body1, mtmp, tmp);
if (cmask)
{
- tmp1 = gfc_build_array_ref (cmask, count);
+ tmp1 = gfc_build_array_ref (cmask, count, NULL);
tmp = cond;
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
if (pmask)
{
- tmp1 = gfc_build_array_ref (pmask, count);
+ tmp1 = gfc_build_array_ref (pmask, count, NULL);
tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
/* Form the mask expression according to the mask. */
index = count1;
- maskexpr = gfc_build_array_ref (mask, index);
+ maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
/* Form the mask expression according to the mask tree list. */
index = count2;
- maskexpr = gfc_build_array_ref (mask, index);
+ maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
maskexpr);
/* Build an ARRAY_REF with its natural type. */
tree
-gfc_build_array_ref (tree base, tree offset)
+gfc_build_array_ref (tree base, tree offset, tree decl)
{
tree type = TREE_TYPE (base);
+ tree tmp;
+
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
type = TREE_TYPE (type);
/* Strip NON_LVALUE_EXPR nodes. */
STRIP_TYPE_NOPS (offset);
- return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
+ /* 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
+ || TREE_CODE (decl) == VAR_DECL
+ || TREE_CODE (decl) == PARM_DECL)
+ && GFC_DECL_SUBREF_ARRAY_P (decl)
+ && !integer_zerop (GFC_DECL_SPAN(decl)))
+ {
+ offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ offset, GFC_DECL_SPAN(decl));
+ tmp = gfc_build_addr_expr (pvoid_type_node, base);
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
+ tmp, fold_convert (sizetype, offset));
+ tmp = fold_convert (build_pointer_type (type), tmp);
+ if (!TYPE_STRING_FLAG (type))
+ tmp = build_fold_indirect_ref (tmp);
+ return tmp;
+ }
+ else
+ /* Otherwise use a straightforward array reference. */
+ return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
}
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
-void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent);
-bool is_aliased_array (gfc_expr *);
+void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
-tree gfc_build_array_ref (tree, tree);
+tree gfc_build_array_ref (tree, tree, tree);
/* Creates a label. Decl is artificial if label_id == NULL_TREE. */
tree gfc_build_label_decl (tree);
address of target label. */
tree stringlen;
tree addr;
+ tree span;
};
#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
+#define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
#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)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
+2007-09-16 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/29396
+ PR fortran/29606
+ PR fortran/30625
+ PR fortran/30871
+ * gfortran.dg/subref_array_pointer_1.f90: New test.
+ * gfortran.dg/subref_array_pointer_2.f90: New test.
+
2007-09-15 H.J. Lu <hongjiu.lu@intel.com>
* gfortran.dg/nint_2.f90: Correct last change.
--- /dev/null
+! { dg-do run }
+! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+! to arrays with subreferences did not work.
+!
+ call pr29396
+ call pr29606
+ call pr30625
+ call pr30871
+contains
+ subroutine pr29396
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+ CHARACTER(LEN=2), DIMENSION(:), POINTER :: a
+ CHARACTER(LEN=4), DIMENSION(3), TARGET :: b
+ b=(/"bbbb","bbbb","bbbb"/)
+ a=>b(:)(2:3)
+ a="aa"
+ IF (ANY(b.NE.(/"baab","baab","baab"/))) CALL ABORT()
+ END subroutine
+
+ subroutine pr29606
+! Contributed by Daniel Franke <franke.daniel@gmail.com>
+ TYPE foo
+ INTEGER :: value
+ END TYPE
+ TYPE foo_array
+ TYPE(foo), DIMENSION(:), POINTER :: array
+ END TYPE
+ TYPE(foo_array) :: array_holder
+ INTEGER, DIMENSION(:), POINTER :: array_ptr
+ ALLOCATE( array_holder%array(3) )
+ array_holder%array = (/ foo(1), foo(2), foo(3) /)
+ array_ptr => array_holder%array%value
+ if (any (array_ptr .ne. (/1,2,3/))) call abort ()
+ END subroutine
+
+ subroutine pr30625
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ type :: a
+ real :: r = 3.14159
+ integer :: i = 42
+ end type a
+ type(a), target :: dt(2)
+ integer, pointer :: ip(:)
+ ip => dt%i
+ if (any (ip .ne. 42)) call abort ()
+ end subroutine
+
+ subroutine pr30871
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ TYPE data
+ CHARACTER(LEN=3) :: A
+ END TYPE
+ TYPE(data), DIMENSION(10), TARGET :: Z
+ CHARACTER(LEN=1), DIMENSION(:), POINTER :: ptr
+ Z(:)%A="123"
+ ptr=>Z(:)%A(2:2)
+ if (any (ptr .ne. "2")) call abort ()
+ END subroutine
+end
--- /dev/null
+! { dg-do run }
+! Test the fix for PRs29396, 29606, 30625 and 30871, in which pointers
+! to arrays with subreferences did not work.
+!
+ type :: t
+ real :: r
+ integer :: i
+ character(3) :: chr
+ end type t
+
+ type :: t2
+ real :: r(2, 2)
+ integer :: i
+ character(3) :: chr
+ end type t2
+
+ type :: s
+ type(t), pointer :: t(:)
+ end type s
+
+ integer, parameter :: sh(2) = (/2,2/)
+ real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh)
+ real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh)
+
+ type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/)
+ character(4), target :: tar2(2) = (/"abcd","efgh"/)
+ type(s), target :: tar3
+ character(2), target :: tar4(2) = (/"ab","cd"/)
+ type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/)
+
+ integer, pointer :: ptr(:)
+ character(2), pointer :: ptr2(:)
+ real, pointer :: ptr3(:)
+
+!_______________component subreference___________
+ ptr => tar1%i
+ ptr = ptr + 1 ! check the scalarizer is OK
+
+ if (any (ptr .ne. (/3, 5/))) call abort ()
+ if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) call abort ()
+ if (any (tar1%i .ne. (/3, 5/))) call abort ()
+
+! Make sure that the other components are not touched.
+ if (any (tar1%r .ne. (/1.0, 3.0/))) call abort ()
+ if (any (tar1%chr .ne. (/"abc", "efg"/))) call abort ()
+
+! Check that the pointer is passed correctly as an actual argument.
+ call foo (ptr)
+ if (any (tar1%i .ne. (/2, 4/))) call abort ()
+
+! And that dummy pointers are OK too.
+ call bar (ptr)
+ if (any (tar1%i .ne. (/101, 103/))) call abort ()
+
+!_______________substring subreference___________
+ ptr2 => tar2(:)(2:3)
+ ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer
+
+ if (any (ptr2 .ne. (/"cz", "gz"/))) call abort ()
+ if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) call abort ()
+ if (any (tar2 .ne. (/"aczd", "egzh"/))) call abort ()
+
+!_______________substring component subreference___________
+ ptr2 => tar1(:)%chr(1:2)
+ ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer
+ if (any (ptr2 .ne. (/"bq","fq"/))) call abort ()
+ if (any (tar1%chr .ne. (/"bqc","fqg"/))) call abort ()
+
+!_______________trailing array element subreference___________
+ ptr3 => tar5%r(1,2)
+ ptr3 = (/99.0, 999.0/)
+ if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) call abort ()
+ if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) call abort ()
+
+!_______________forall assignment___________
+ ptr2 => tar2(:)(1:2)
+ forall (i = 1:2) ptr2(i)(1:1) = "z"
+ if (any (tar2 .ne. (/"zczd", "zgzh"/))) call abort ()
+
+!_______________something more complicated___________
+ tar3%t => tar1
+ ptr3 => tar3%t%r
+ ptr3 = cos (ptr3)
+ if (any (ptr3 .ne. (/cos(1.0_4), cos(3.0_4)/))) call abort ()
+
+ ptr2 => tar3%t(:)%chr(2:3)
+ ptr2 = " x"
+ if (any (tar1%chr .ne. (/"b x", "f x"/))) call abort ()
+
+!_______________check non-subref works still___________
+ ptr2 => tar4
+ if (any (ptr2 .ne. (/"ab","cd"/))) call abort ()
+
+contains
+ subroutine foo (arg)
+ integer :: arg(:)
+ arg = arg - 1
+ end subroutine
+ subroutine bar (arg)
+ integer, pointer :: arg(:)
+ arg = arg + 99
+ end subroutine
+end
OSDN Git Service
