desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
- info->descriptor = desc;
- size = gfc_index_one_node;
-
/* Emit a DECL_EXPR for the variable sized array type in
GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
sizes works correctly. */
gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
arraytype, TYPE_NAME (arraytype)));
- /* Fill in the array dtype. */
- tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ if (class_expr != NULL_TREE)
+ {
+ tree class_data;
+ tree dtype;
+
+ /* Create a class temporary. */
+ tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
+ gfc_add_modify (pre, tmp, class_expr);
+
+ /* Assign the new descriptor to the _data field. This allows the
+ vptr _copy to be used for scalarized assignment since the class
+ temporary can be found from the descriptor. */
+ class_data = gfc_class_data_get (tmp);
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (desc), desc);
+ gfc_add_modify (pre, class_data, tmp);
+
+ /* Take the dtype from the class expression. */
+ dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
+ tmp = gfc_conv_descriptor_dtype (class_data);
+ gfc_add_modify (pre, tmp, dtype);
+
+ /* Point desc to the class _data field. */
+ desc = class_data;
+ }
+ else
+ {
+ /* Fill in the array dtype. */
+ tmp = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ }
+
+ info->descriptor = desc;
+ size = gfc_index_one_node;
/*
Fill in the bounds and stride. This is a packed array, so:
static bool
build_class_array_ref (gfc_se *se, tree base, tree index)
{
- tree type;
tree size;
- tree offset;
tree decl = NULL_TREE;
tree tmp;
gfc_expr *expr = se->ss->info->expr;
- gfc_ref *ref;
- gfc_ref *class_ref = NULL;
+ gfc_expr *class_expr;
gfc_typespec *ts;
+ gfc_symbol *sym;
- if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
- && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
- && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
- decl = se->expr;
+ tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
+
+ if (tmp != NULL_TREE)
+ decl = tmp;
else
{
- if (expr == NULL
+ /* The base expression does not contain a class component, either
+ because it is a temporary array or array descriptor. Class
+ array functions are correctly resolved above. */
+ if (!expr
|| (expr->ts.type != BT_CLASS
- && !gfc_is_class_array_function (expr)
&& !gfc_is_class_array_ref (expr, NULL)))
return false;
- if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
- ts = &expr->symtree->n.sym->ts;
- else
- ts = NULL;
-
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS
- && ref->next && ref->next->type == REF_COMPONENT
- && strcmp (ref->next->u.c.component->name, "_data") == 0
- && ref->next->next
- && ref->next->next->type == REF_ARRAY
- && ref->next->next->u.ar.type != AR_ELEMENT)
- {
- ts = &ref->u.c.component->ts;
- class_ref = ref;
- break;
- }
- }
+ /* Obtain the expression for the class entity or component that is
+ followed by an array reference, which is not an element, so that
+ the span of the array can be obtained. */
+ class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
- if (ts == NULL)
+ if (!ts)
return false;
- }
- if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
- && expr->symtree->n.sym == expr->symtree->n.sym->result
- && expr->symtree->n.sym->backend_decl == current_function_decl)
- {
- decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
- }
- else if (expr && gfc_is_class_array_function (expr))
- {
- size = NULL_TREE;
- decl = NULL_TREE;
- for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
- {
- tree type;
- type = TREE_TYPE (tmp);
- while (type)
- {
- if (GFC_CLASS_TYPE_P (type))
- decl = tmp;
- if (type != TYPE_CANONICAL (type))
- type = TYPE_CANONICAL (type);
- else
- type = NULL_TREE;
- }
- if (VAR_P (tmp))
- break;
+ sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
+ if (sym && sym->attr.function
+ && sym == sym->result
+ && sym->backend_decl == current_function_decl)
+ /* The temporary is the data field of the class data component
+ of the current function. */
+ decl = gfc_get_fake_result_decl (sym, 0);
+ else if (sym)
+ {
+ if (decl == NULL_TREE)
+ decl = expr->symtree->n.sym->backend_decl;
+ /* For class arrays the tree containing the class is stored in
+ GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
+ For all others it's sym's backend_decl directly. */
+ if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
+ else
+ decl = gfc_get_class_from_gfc_expr (class_expr);
- if (decl == NULL_TREE)
- return false;
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
- se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
- }
- else if (class_ref == NULL)
- {
- if (decl == NULL_TREE)
- decl = expr->symtree->n.sym->backend_decl;
- /* For class arrays the tree containing the class is stored in
- GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
- For all others it's sym's backend_decl directly. */
- if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- }
- else
- {
- /* Remove everything after the last class reference, convert the
- expression and then recover its tailend once more. */
- gfc_se tmpse;
- ref = class_ref->next;
- class_ref->next = NULL;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, expr);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- decl = tmpse.expr;
- class_ref->next = ref;
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+ return false;
}
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
-
- if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- return false;
+ se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
size = gfc_class_vtab_size_get (decl);
-
/* For unlimited polymorphic entities then _len component needs to be
multiplied with the size. */
size = gfc_resize_class_size_with_len (&se->pre, decl, size);
-
size = fold_convert (TREE_TYPE (index), size);
- /* Build the address of the element. */
- type = TREE_TYPE (TREE_TYPE (base));
- offset = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- index, size);
- tmp = gfc_build_addr_expr (pvoid_type_node, base);
- tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
- tmp = fold_convert (build_pointer_type (type), tmp);
-
/* Return the element in the se expression. */
- se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+ se->expr = gfc_build_spanned_array_ref (base, index, size);
return true;
}
}
else if (expr1->ts.type == BT_CLASS)
{
- tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
- if (tmp == NULL_TREE)
- tmp = gfc_get_class_from_gfc_expr (expr1);
-
- if (tmp != NULL_TREE)
- {
- tmp2 = gfc_class_vptr_get (tmp);
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, tmp2,
- build_int_cst (TREE_TYPE (tmp2), 0));
- elemsize1 = gfc_class_vtab_size_get (tmp);
- elemsize1 = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- elemsize1, gfc_index_zero_node);
- }
- else
- elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+ /* Unfortunately, the lhs vptr is set too early in many cases.
+ Play it safe by using the descriptor element length. */
+ tmp = gfc_conv_descriptor_elem_len (desc);
+ elemsize1 = fold_convert (gfc_array_index_type, tmp);
}
else
elemsize1 = NULL_TREE;
/* We already set the dtype in the case of deferred character
- length arrays and unlimited polymorphic arrays. */
+ length arrays and class lvalues. */
if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
|| coarray))
- && !UNLIMITED_POLY (expr1))
+ && expr1->ts.type != BT_CLASS)
{
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
#undef VTABLE_FINAL_FIELD
-/* Search for the last _class ref in the chain of references of this
- expression and cut the chain there. Albeit this routine is similiar
- to class.c::gfc_add_component_ref (), is there a significant
- difference: gfc_add_component_ref () concentrates on an array ref to
- be the last ref in the chain. This routine is oblivious to the kind
- of refs following. */
+/* IF ts is null (default), search for the last _class ref in the chain
+ of references of the expression and cut the chain there. Although
+ this routine is similiar to class.c:gfc_add_component_ref (), there
+ is a significant difference: gfc_add_component_ref () concentrates
+ on an array ref that is the last ref in the chain and is oblivious
+ to the kind of refs following.
+ ELSE IF ts is non-null the cut is at the class entity or component
+ that is followed by an array reference, which is not an element.
+ These calls come from trans-array.c:build_class_array_ref, which
+ handles scalarized class array references.*/
gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
+ gfc_typespec **ts)
{
gfc_expr *base_expr;
gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
/* Find the last class reference. */
class_ref = NULL;
array_ref = NULL;
- for (ref = e->ref; ref; ref = ref->next)
+
+ if (ts)
{
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
- array_ref = ref;
+ if (e->symtree
+ && e->symtree->n.sym->ts.type == BT_CLASS)
+ *ts = &e->symtree->n.sym->ts;
+ else
+ *ts = NULL;
+ }
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->ts.type == BT_CLASS)
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ts)
{
- /* Component to the right of a part reference with nonzero rank
- must not have the ALLOCATABLE attribute. If attempts are
- made to reference such a component reference, an error results
- followed by an ICE. */
- if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
- return NULL;
- class_ref = ref;
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS
+ && ref->next && ref->next->type == REF_COMPONENT
+ && !strcmp (ref->next->u.c.component->name, "_data")
+ && ref->next->next
+ && ref->next->next->type == REF_ARRAY
+ && ref->next->next->u.ar.type != AR_ELEMENT)
+ {
+ *ts = &ref->u.c.component->ts;
+ class_ref = ref;
+ break;
+ }
+
+ if (ref->next == NULL)
+ break;
}
+ else
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+ array_ref = ref;
- if (ref->next == NULL)
- break;
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->ts.type == BT_CLASS)
+ {
+ /* Component to the right of a part reference with nonzero
+ rank must not have the ALLOCATABLE attribute. If attempts
+ are made to reference such a component reference, an error
+ results followed by an ICE. */
+ if (array_ref
+ && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+ return NULL;
+ class_ref = ref;
+ }
+ }
}
+ if (ts && *ts == NULL)
+ return NULL;
+
/* Remove and store all subsequent references after the
CLASS reference. */
if (class_ref)
gfc_add_modify (&block, lse->expr, tmp);
}
/* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
- else if (ts.type == BT_CLASS
- && !trans_scalar_class_assign (&block, lse, rse))
+ else if (ts.type == BT_CLASS)
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
- /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
- for the lhs which ensures that class data rhs cast as a string assigns
- correctly. */
- tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (rse->expr), lse->expr);
- gfc_add_modify (&block, tmp, rse->expr);
+
+ if (!trans_scalar_class_assign (&block, lse, rse))
+ {
+ /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+ for the lhs which ensures that class data rhs cast as a string assigns
+ correctly. */
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (rse->expr), lse->expr);
+ gfc_add_modify (&block, tmp, rse->expr);
+ }
}
else if (ts.type != BT_CLASS)
{
return NULL_TREE;
}
span = gfc_class_vtab_size_get (decl);
+ /* For unlimited polymorphic entities then _len component needs
+ to be multiplied with the size. */
+ span = gfc_resize_class_size_with_len (NULL, decl, span);
}
else if (GFC_DECL_PTR_ARRAY_P (decl))
{
}
+tree
+gfc_build_spanned_array_ref (tree base, tree offset, tree span)
+{
+ tree type;
+ tree tmp;
+ type = TREE_TYPE (TREE_TYPE (base));
+ offset = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ offset, span);
+ tmp = gfc_build_addr_expr (pvoid_type_node, base);
+ tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+ tmp = fold_convert (build_pointer_type (type), tmp);
+ if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
+ || !TYPE_STRING_FLAG (type))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ return tmp;
+}
+
+
/* Build an ARRAY_REF with its natural type. */
tree
gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
{
tree type = TREE_TYPE (base);
- tree tmp;
tree span = NULL_TREE;
if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
if (span != NULL_TREE)
- {
- offset = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- offset, span);
- tmp = gfc_build_addr_expr (pvoid_type_node, base);
- tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
- tmp = fold_convert (build_pointer_type (type), tmp);
- if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
- || !TYPE_STRING_FLAG (type))
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- return tmp;
- }
+ return gfc_build_spanned_array_ref (base, offset, span);
/* Otherwise use a straightforward array reference. */
else
return build4_loc (input_location, ARRAY_REF, type, base, offset,