/* Expression translation
- Copyright (C) 2002-2015 Free Software Foundation, Inc.
+ Copyright (C) 2002-2017 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "trans.h"
#include "stringpool.h"
#include "diagnostic-core.h" /* For fatal_error. */
-#include "alias.h"
#include "fold-const.h"
#include "langhooks.h"
-#include "flags.h"
#include "arith.h"
#include "constructor.h"
#include "trans-const.h"
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
+ if (CONSTANT_CLASS_P (scalar))
+ {
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (&se->pre, tmp, scalar);
+ scalar = tmp;
+ }
if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = gfc_build_addr_expr (NULL_TREE, scalar);
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
}
+/* Get the coarray token from the ultimate array or component ref.
+ Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
+
+tree
+gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
+{
+ gfc_symbol *sym = expr->symtree->n.sym;
+ bool is_coarray = sym->attr.codimension;
+ gfc_expr *caf_expr = gfc_copy_expr (expr);
+ gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
+
+ while (ref)
+ {
+ if (ref->type == REF_COMPONENT
+ && (ref->u.c.component->attr.allocatable
+ || ref->u.c.component->attr.pointer)
+ && (is_coarray || ref->u.c.component->attr.codimension))
+ last_caf_ref = ref;
+ ref = ref->next;
+ }
+
+ if (last_caf_ref == NULL)
+ return NULL_TREE;
+
+ tree comp = last_caf_ref->u.c.component->caf_token, caf;
+ gfc_se se;
+ bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
+ if (comp == NULL_TREE && comp_ref)
+ return NULL_TREE;
+ gfc_init_se (&se, outerse);
+ gfc_free_ref_list (last_caf_ref->next);
+ last_caf_ref->next = NULL;
+ caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
+ se.want_pointer = comp_ref;
+ gfc_conv_expr (&se, caf_expr);
+ gfc_add_block_to_block (&outerse->pre, &se.pre);
+
+ if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
+ se.expr = TREE_OPERAND (se.expr, 0);
+ gfc_free_expr (caf_expr);
+
+ if (comp_ref)
+ caf = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (comp), se.expr, comp, NULL_TREE);
+ else
+ caf = gfc_conv_descriptor_token (se.expr);
+ return gfc_build_addr_expr (NULL_TREE, caf);
+}
+
+
/* This is the seed for an eventual trans-class.c
The following parameters should not be used directly since they might
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
#define VTABLE_FINAL_FIELD 5
+#define VTABLE_DEALLOCATE_FIELD 6
tree
tree vptr;
/* For class arrays decl may be a temporary descriptor handle, the vptr is
then available through the saved descriptor. */
- if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+ if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
tree len;
/* For class arrays decl may be a temporary descriptor handle, the len is
then available through the saved descriptor. */
- if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+ if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
&& GFC_DECL_SAVED_DESCRIPTOR (decl))
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
}
+/* Try to get the _len component of a class. When the class is not unlimited
+ poly, i.e. no _len field exists, then return a zero node. */
+
+tree
+gfc_class_len_or_zero_get (tree decl)
+{
+ tree len;
+ /* For class arrays decl may be a temporary descriptor handle, the vptr is
+ then available through the saved descriptor. */
+ if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+ len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
+ CLASS_LEN_FIELD);
+ return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len), decl, len,
+ NULL_TREE)
+ : integer_zero_node;
+}
+
+
/* Get the specified FIELD from the VPTR. */
static tree
VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
+VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
/* The size field is returned as an array index type. Therefore treat
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
+#undef CLASS_LEN_FIELD
#undef VTABLE_HASH_FIELD
#undef VTABLE_SIZE_FIELD
#undef VTABLE_EXTENDS_FIELD
gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
{
gfc_expr *base_expr;
- gfc_ref *ref, *class_ref, *tail, *array_ref;
+ 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 (ref->type == REF_ARRAY
- && ref->u.ar.type != AR_ELEMENT)
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
array_ref = ref;
if (ref->type == REF_COMPONENT
/* 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 anICE. */
- if (array_ref
- && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+ followed by an ICE. */
+ if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
return NULL;
- class_ref = ref;
+ class_ref = ref;
}
if (ref->next == NULL)
tail = class_ref->next;
class_ref->next = NULL;
}
- else
+ else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tail = e->ref;
e->ref = NULL;
gfc_free_ref_list (class_ref->next);
class_ref->next = tail;
}
- else
+ else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
gfc_free_ref_list (e->ref);
e->ref = tail;
else
type = NULL_TREE;
}
- if (TREE_CODE (tmp) == VAR_DECL)
+ if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
break;
}
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ return gfc_class_vptr_get (tmp);
+
return NULL_TREE;
}
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
- if (parmse->ss && parmse->ss->info->useflags)
+ if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ {
+ /* If there is a ready made pointer to a derived type, use it
+ rather than evaluating the expression again. */
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
-
}
else
{
{
ctree = gfc_class_len_get (var);
/* When the actual arg is a char array, then set the _len component of the
- unlimited polymorphic entity, too. */
+ unlimited polymorphic entity to the length of the string. */
if (e->ts.type == BT_CHARACTER)
{
/* Start with parmse->string_length because this seems to be set to a
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tmp = e->symtree->n.sym->backend_decl;
+
+ if (TREE_CODE (tmp) == FUNCTION_DECL)
+ tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
+
if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+
slen = integer_zero_node;
}
else
tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Return the len component, except in the case of scalarized array
+ references, where the dynamic type cannot change. */
+ if (!elemental && full_array && copyback)
+ gfc_add_modify (&parmse->post, tmp,
+ fold_convert (TREE_TYPE (tmp), ctree));
}
if (optional)
}
else
{
- from_data = gfc_class_data_get (from);
+ /* Check that from is a class. When the class is part of a coarray,
+ then from is a common pointer and is to be used as is. */
+ tmp = POINTER_TYPE_P (TREE_TYPE (from))
+ ? build_fold_indirect_ref (from) : from;
+ from_data =
+ (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
+ ? gfc_class_data_get (from) : from;
is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
}
}
if (unlimited)
{
if (from != NULL_TREE && unlimited)
- from_len = gfc_class_len_get (from);
+ from_len = gfc_class_len_or_zero_get (from);
else
from_len = integer_zero_node;
}
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
+ tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block (&body);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
}
vec_safe_push (args, to_ref);
+ /* Add bounds check. */
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
+ {
+ char *msg;
+ const char *name = "<<unknown>>";
+ tree from_len;
+
+ if (DECL_P (to))
+ name = (const char *)(DECL_NAME (to)->identifier.id.str);
+
+ from_len = gfc_conv_descriptor_size (from_data, 1);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, from_len, orig_nelems);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ 1, name);
+
+ gfc_trans_runtime_check (true, false, tmp, &body,
+ &gfc_current_locus, msg,
+ fold_convert (long_integer_type_node, orig_nelems),
+ fold_convert (long_integer_type_node, from_len));
+
+ free (msg);
+ }
+
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
rhs->rank = 0;
if (code->expr1->ts.type == BT_CLASS
- && CLASS_DATA (code->expr1)->attr.dimension)
- tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ && CLASS_DATA (code->expr1)->attr.dimension)
+ {
+ gfc_array_spec *tmparr = gfc_get_array_spec ();
+ *tmparr = *CLASS_DATA (code->expr1)->as;
+ gfc_add_full_array_ref (lhs, tmparr);
+ tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+ }
else
{
sz = gfc_copy_expr (code->expr1);
}
-/* Translate an assignment to a CLASS object
- (pointer or ordinary assignment). */
-
-tree
-gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
-{
- stmtblock_t block;
- tree tmp;
- gfc_expr *lhs;
- gfc_expr *rhs;
- gfc_ref *ref;
-
- gfc_start_block (&block);
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- /* Class valued proc_pointer assignments do not need any further
- preparation. */
- if (ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && op == EXEC_POINTER_ASSIGN)
- goto assign;
-
- if (expr2->ts.type != BT_CLASS)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- gfc_symbol *vtab = NULL;
- gfc_symtree *st;
-
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- if (UNLIMITED_POLY (expr1)
- && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
- {
- rhs = gfc_get_null_expr (&expr2->where);
- goto assign_vptr;
- }
-
- if (expr2->expr_type == EXPR_NULL)
- vtab = gfc_find_vtab (&expr1->ts);
- else
- vtab = gfc_find_vtab (&expr2->ts);
- gcc_assert (vtab);
-
- rhs = gfc_get_expr ();
- rhs->expr_type = EXPR_VARIABLE;
- gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
- rhs->symtree = st;
- rhs->ts = vtab->ts;
-assign_vptr:
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
- else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
- {
- /* F2003:C717 only sequence and bind-C types can come here. */
- gcc_assert (expr1->ts.u.derived->attr.sequence
- || expr1->ts.u.derived->attr.is_bind_c);
- gfc_add_data_component (expr2);
- goto assign;
- }
- else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION)
- {
- /* Insert an additional assignment which sets the '_vptr' field. */
- lhs = gfc_copy_expr (expr1);
- gfc_add_vptr_component (lhs);
-
- rhs = gfc_copy_expr (expr2);
- gfc_add_vptr_component (rhs);
-
- tmp = gfc_trans_pointer_assignment (lhs, rhs);
- gfc_add_expr_to_block (&block, tmp);
-
- gfc_free_expr (lhs);
- gfc_free_expr (rhs);
- }
-
- /* Do the actual CLASS assignment. */
- if (expr2->ts.type == BT_CLASS
- && !CLASS_DATA (expr2)->attr.dimension)
- op = EXEC_ASSIGN;
- else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS
- || !CLASS_DATA (expr2)->attr.dimension)
- gfc_add_data_component (expr1);
-
-assign:
-
- if (op == EXEC_ASSIGN)
- tmp = gfc_trans_assignment (expr1, expr2, false, true);
- else if (op == EXEC_POINTER_ASSIGN)
- tmp = gfc_trans_pointer_assignment (expr1, expr2);
- else
- gcc_unreachable();
-
- gfc_add_expr_to_block (&block, tmp);
-
- return gfc_finish_block (&block);
-}
-
-
/* End of prototype trans-class.c */
{
tree caf_decl;
bool found = false;
- gfc_ref *ref, *comp_ref = NULL;
+ gfc_ref *ref;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
/* Not-implemented diagnostic. */
+ if (expr->symtree->n.sym->ts.type == BT_CLASS
+ && UNLIMITED_POLY (expr->symtree->n.sym)
+ && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
+ "%L is not supported", &expr->where);
+
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
{
- comp_ref = ref;
- if ((ref->u.c.component->ts.type == BT_CLASS
- && !CLASS_DATA (ref->u.c.component)->attr.codimension
- && (CLASS_DATA (ref->u.c.component)->attr.pointer
- || CLASS_DATA (ref->u.c.component)->attr.allocatable))
- || (ref->u.c.component->ts.type != BT_CLASS
- && !ref->u.c.component->attr.codimension
- && (ref->u.c.component->attr.pointer
- || ref->u.c.component->attr.allocatable)))
- gfc_error ("Sorry, coindexed access to a pointer or allocatable "
- "component of the coindexed coarray at %L is not yet "
- "supported", &expr->where);
+ if (ref->u.c.component->ts.type == BT_CLASS
+ && UNLIMITED_POLY (ref->u.c.component)
+ && CLASS_DATA (ref->u.c.component)->attr.codimension)
+ gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
+ "component at %L is not supported", &expr->where);
}
- if ((!comp_ref
- && ((expr->symtree->n.sym->ts.type == BT_CLASS
- && CLASS_DATA (expr->symtree->n.sym)->attr.alloc_comp)
- || (expr->symtree->n.sym->ts.type == BT_DERIVED
- && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)))
- || (comp_ref
- && ((comp_ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (comp_ref->u.c.component)->attr.alloc_comp)
- || (comp_ref->u.c.component->ts.type == BT_DERIVED
- && comp_ref->u.c.component->ts.u.derived->attr.alloc_comp))))
- gfc_error ("Sorry, coindexed coarray at %L with allocatable component is "
- "not yet supported", &expr->where);
-
- if (expr->rank)
- {
- /* Without the new array descriptor, access like "caf[i]%a(:)%b" is in
- general not possible as the required stride multiplier might be not
- a multiple of c_sizeof(b). In case of noncoindexed access, the
- scalarizer often takes care of it - for coarrays, it always fails. */
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && ((ref->u.c.component->ts.type == BT_CLASS
- && CLASS_DATA (ref->u.c.component)->attr.codimension)
- || (ref->u.c.component->ts.type != BT_CLASS
- && ref->u.c.component->attr.codimension)))
- break;
- if (ref == NULL)
- ref = expr->ref;
- for ( ; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.dimen)
- break;
- for ( ; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- gfc_error ("Sorry, coindexed access at %L to a scalar component "
- "with an array partref is not yet supported",
- &expr->where);
- }
- caf_decl = expr->symtree->n.sym->backend_decl;
- gcc_assert (caf_decl);
+ /* Make sure the backend_decl is present before accessing it. */
+ caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
+ ? gfc_get_symbol_decl (expr->symtree->n.sym)
+ : expr->symtree->n.sym->backend_decl;
+
if (expr->symtree->n.sym->ts.type == BT_CLASS)
- caf_decl = gfc_class_data_get (caf_decl);
+ {
+ if (expr->ref && expr->ref->type == REF_ARRAY)
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ return caf_decl;
+ }
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && strcmp (ref->u.c.component->name, "_data") != 0)
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
+ return caf_decl;
+ break;
+ }
+ else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
+ break;
+ }
+ }
if (expr->symtree->n.sym->attr.codimension)
return caf_decl;
TREE_TYPE (comp->backend_decl), caf_decl,
comp->backend_decl, NULL_TREE);
if (comp->ts.type == BT_CLASS)
- caf_decl = gfc_class_data_get (caf_decl);
+ {
+ caf_decl = gfc_class_data_get (caf_decl);
+ if (CLASS_DATA (comp)->attr.codimension)
+ {
+ found = true;
+ break;
+ }
+ }
if (comp->attr.codimension)
{
found = true;
/* Obtain the Coarray token - and optionally also the offset. */
void
-gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
- gfc_expr *expr)
+gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
+ tree se_expr, gfc_expr *expr)
{
tree tmp;
*offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
*offset, fold_convert (gfc_array_index_type, tmp));
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+ if (expr->symtree->n.sym->ts.type == BT_DERIVED
+ && expr->symtree->n.sym->attr.codimension
+ && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+ {
+ gfc_expr *base_expr = gfc_copy_expr (expr);
+ gfc_ref *ref = base_expr->ref;
+ gfc_se base_se;
+
+ // Iterate through the refs until the last one.
+ while (ref->next)
+ ref = ref->next;
+
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_FULL)
+ {
+ const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
+ int i;
+ for (i = 0; i < ranksum; ++i)
+ {
+ ref->u.ar.start[i] = NULL;
+ ref->u.ar.end[i] = NULL;
+ }
+ ref->u.ar.type = AR_FULL;
+ }
+ gfc_init_se (&base_se, NULL);
+ if (gfc_caf_attr (base_expr).dimension)
+ {
+ gfc_conv_expr_descriptor (&base_se, base_expr);
+ tmp = gfc_conv_descriptor_data_get (base_se.expr);
+ }
+ else
+ {
+ gfc_conv_expr (&base_se, base_expr);
+ tmp = base_se.expr;
+ }
+
+ gfc_free_expr (base_expr);
+ gfc_add_block_to_block (&se->pre, &base_se.pre);
+ gfc_add_block_to_block (&se->post, &base_se.post);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
tmp = gfc_conv_descriptor_data_get (caf_decl);
else
{
break;
gcc_assert (ref != NULL);
+ if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
+ {
+ return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+ integer_zero_node);
+ }
+
img_idx = integer_zero_node;
extent = integer_one_node;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
}
/* Otherwise, fall through to handle constructor elements. */
+ gcc_fallthrough ();
case EXPR_STRUCTURE:
for (c = gfc_constructor_first (e->value.constructor);
c; c = gfc_constructor_next (c))
gfc_init_se (&se, NULL);
- if (!cl->length
- && cl->backend_decl
- && TREE_CODE (cl->backend_decl) == VAR_DECL)
+ if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
return;
/* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
else
- msg = xasprintf ("Substring out of bounds: lower bound (%%ld)"
+ msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
"is less than one");
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
tree tmp;
tree decl;
tree field;
+ tree context;
c = ref->u.c.component;
field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
+ context = DECL_FIELD_CONTEXT (field);
/* Components can correspond to fields of different containing
types, as components are created without context, whereas
a concrete use of a component has the type of decl as context.
So, if the type doesn't match, we search the corresponding
FIELD_DECL in the parent type. To not waste too much time
- we cache this result in norestrict_decl. */
+ we cache this result in norestrict_decl.
+ On the other hand, if the context is a UNION or a MAP (a
+ RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
- if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+ if (context != TREE_TYPE (decl)
+ && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
+ || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
{
tree f2 = c->norestrict_decl;
if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
if (se_expr)
se->expr = se_expr;
- /* Procedure actual arguments. */
- else if (sym->attr.flavor == FL_PROCEDURE
+ /* Procedure actual arguments. Look out for temporary variables
+ with the same attributes as function values. */
+ else if (!sym->attr.temporary
+ && sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
if (!sym->attr.dummy && !sym->attr.proc_pointer)
return 0;
m = wrhs.to_shwi ();
- /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
- of the asymmetric range of the integer type. */
- n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
+ /* Use the wide_int's routine to reliably get the absolute value on all
+ platforms. Then convert it to a HOST_WIDE_INT like above. */
+ n = wi::abs (wrhs).to_shwi ();
type = TREE_TYPE (lhs);
sgn = tree_int_cst_sgn (rhs);
gfc_ref *ref;
tree var;
- if (TREE_CODE (base_object) != VAR_DECL)
+ if (!VAR_P (base_object))
{
var = gfc_create_var (TREE_TYPE (base_object), NULL);
gfc_add_modify (&se->pre, var, base_object);
if (sym->attr.flavor == FL_PROCEDURE)
value = se->expr;
+ /* If the argument is a pass-by-value scalar, use the value as is. */
+ else if (!sym->attr.dimension && sym->attr.value)
+ value = se->expr;
+
/* If the argument is either a string or a pointer to a string,
convert it to a boundless character type. */
else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
break;
+ case GFC_ISYM_LEN_TRIM:
+ new_expr = gfc_copy_expr (arg1);
+ gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+
+ if (!new_expr)
+ return false;
+
+ gfc_replace_expr (arg1, new_expr);
+ return true;
+
case GFC_ISYM_SIZE:
if (!sym->as || sym->as->rank == 0)
return false;
{
gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
- if ((proc_ifc->result->ts.type == BT_CLASS
- && proc_ifc->result->ts.u.derived->attr.is_class
- && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
- || proc_ifc->result->attr.pointer)
+ if (proc_ifc->result != NULL
+ && ((proc_ifc->result->ts.type == BT_CLASS
+ && proc_ifc->result->ts.u.derived->attr.is_class
+ && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
+ || proc_ifc->result->attr.pointer))
return true;
else
return false;
is the third and fourth argument to such a function call a value
denoting the number of elements to copy (i.e., most of the time the
length of a deferred length string). */
- ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
- && strcmp ("_copy", comp->name) == 0;
+ ulim_copy = (formal == NULL)
+ && UNLIMITED_POLY (sym)
+ && comp && (strcmp ("_copy", comp->name) == 0);
/* Evaluate the arguments. */
for (arg = args, argc = 0; arg != NULL;
ptr = gfc_class_data_get (ptr);
tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
- true, e, e->ts);
+ NULL_TREE, true,
+ e, e->ts);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr,
tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
NULL_TREE, NULL_TREE,
NULL_TREE, true, e,
- false);
+ GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&block, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
void_type_node, ptr,
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
+ if (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived->attr.alloc_comp)
+ {
+ // deallocate the components first
+ tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
+ parmse.expr, e->rank);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp, false, e);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, true,
+ e,
+ GFC_CAF_COARRAY_NOCOARRAY);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
{
tree local_tmp;
local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
+ local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
+ parm_rank, 0);
gfc_add_expr_to_block (&se->post, local_tmp);
}
tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
- gfc_add_expr_to_block (&se->post, tmp);
+ gfc_prepend_expr_to_block (&post, tmp);
}
/* Add argument checking of passing an unallocated/NULL actual to
else
{
tmp = parmse.string_length;
- if (TREE_CODE (tmp) != VAR_DECL)
+ if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
}
if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
&& strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
&& arg->next && arg->next->expr
- && arg->next->expr->ts.type == BT_DERIVED
+ && (arg->next->expr->ts.type == BT_DERIVED
+ || arg->next->expr->ts.type == BT_CLASS)
&& arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
vec_safe_push (stringargs, parmse.string_length);
if (comp)
ts = comp->ts;
+ else if (sym->ts.type == BT_CLASS)
+ ts = CLASS_DATA (sym)->ts;
else
- ts = sym->ts;
+ ts = sym->ts;
if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
len = cl.backend_decl;
}
- byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
- || (!comp && gfc_return_by_reference (sym));
+ byref = (comp && (comp->attr.dimension
+ || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
+ || (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
&& GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
se->expr = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ se->expr);
/* If the lhs of an assignment x = f(..) is allocatable and
f2003 is allowed, we must do the automatic reallocation.
type = gfc_get_character_type (ts.kind, ts.u.cl);
type = build_pointer_type (type);
+ /* Emit a DECL_EXPR for the VLA type. */
+ tmp = TREE_TYPE (type);
+ if (TYPE_SIZE (tmp)
+ && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
+ {
+ tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
+ DECL_ARTIFICIAL (tmp) = 1;
+ DECL_IGNORED_P (tmp) = 1;
+ tmp = fold_build1_loc (input_location, DECL_EXPR,
+ TREE_TYPE (tmp), tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
/* Return an address to a char[0:len-1]* temporary for
character pointers. */
if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
if (ts.type == BT_CHARACTER && ts.deferred)
{
tmp = len;
- if (TREE_CODE (tmp) != VAR_DECL)
+ if (!VAR_P (tmp))
tmp = gfc_evaluate_now (len, &se->pre);
+ TREE_STATIC (tmp) = 1;
+ gfc_add_modify (&se->pre, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
vec_safe_push (retargs, tmp);
}
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
if (!byref && sym->ts.type != BT_CHARACTER
- && sym->attr.allocatable && !sym->attr.dimension)
+ && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
+ || (comp && comp->attr.allocatable && !comp->attr.dimension)))
{
tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, tmp, se->expr);
}
}
+ /* Associate the rhs class object's meta-data with the result, when the
+ result is a temporary. */
+ if (args && args->expr && args->expr->ts.type == BT_CLASS
+ && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
+ {
+ gfc_se parmse;
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
+
+ gfc_init_se (&parmse, NULL);
+ parmse.data_not_needed = 1;
+ gfc_conv_expr (&parmse, class_expr);
+ if (!DECL_LANG_SPECIFIC (result))
+ gfc_allocate_lang_decl (result);
+ GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
+ gfc_free_expr (class_expr);
+ gcc_assert (parmse.pre.head == NULL_TREE
+ && parmse.post.head == NULL_TREE);
+ }
+
/* Follow the function call with the argument post block. */
if (byref)
{
gfc_add_block_to_block (&se->pre, &post);
/* Transformational functions of derived types with allocatable
- components must have the result allocatable components copied. */
+ components must have the result allocatable components copied when the
+ argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
- && expr->value.function.isym
- && expr->value.function.isym->transformational
- && arg->expr->ts.type == BT_DERIVED
- && arg->expr->ts.u.derived->attr.alloc_comp)
+ && expr->value.function.isym
+ && expr->value.function.isym->transformational
+ && arg->expr
+ && arg->expr->ts.type == BT_DERIVED
+ && arg->expr->ts.u.derived->attr.alloc_comp)
{
tree tmp2;
/* Copy the allocatable components. We have to use a
from being corrupted. */
tmp2 = gfc_evaluate_now (result, &se->pre);
tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
- result, tmp2, expr->rank);
+ result, tmp2, expr->rank, 0);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
expr->rank);
tmp = gfc_conv_descriptor_data_get (tmp2);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
NULL_TREE, NULL_TREE, true,
- NULL, false);
+ NULL, GFC_CAF_COARRAY_NOCOARRAY);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
return;
}
+ /* The string copy algorithm below generates code like
+
+ if (dlen > 0) {
+ memmove (dest, src, min(dlen, slen));
+ if (slen < dlen)
+ memset(&dest[slen], ' ', dlen - slen);
+ }
+ */
+
/* Do nothing if the destination length is zero. */
cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen,
build_int_cst (size_type_node, 0));
- /* The following code was previously in _gfortran_copy_string:
-
- // The two strings may overlap so we use memmove.
- void
- copy_string (GFC_INTEGER_4 destlen, char * dest,
- GFC_INTEGER_4 srclen, const char * src)
- {
- if (srclen >= destlen)
- {
- // This will truncate if too long.
- memmove (dest, src, destlen);
- }
- else
- {
- memmove (dest, src, srclen);
- // Pad with spaces.
- memset (&dest[srclen], ' ', destlen - srclen);
- }
- }
-
- We're now doing it here for better optimization, but the logic
- is the same. */
-
/* For non-default character kinds, we have to multiply the string
length by the base type size. */
chartype = gfc_get_char_type (dkind);
else
src = gfc_build_addr_expr (pvoid_type_node, src);
- /* Truncate string if source is too long. */
- cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
- dlen);
+ /* First do the memmove. */
+ tmp2 = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (dlen), dlen,
+ slen);
tmp2 = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src, dlen);
+ 3, dest, src, tmp2);
+ stmtblock_t tmpblock2;
+ gfc_init_block (&tmpblock2);
+ gfc_add_expr_to_block (&tmpblock2, tmp2);
- /* Else copy and pad with spaces. */
- tmp3 = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMMOVE),
- 3, dest, src, slen);
+ /* If the destination is longer, fill the end with spaces. */
+ cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen,
+ dlen);
+
+ /* Wstringop-overflow appears at -O3 even though this warning is not
+ explicitly available in fortran nor can it be switched off. If the
+ source length is a constant, its negative appears as a very large
+ postive number and triggers the warning in BUILTIN_MEMSET. Fixing
+ the result of the MINUS_EXPR suppresses this spurious warning. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE(dlen), dlen, slen);
+ if (slength && TREE_CONSTANT (slength))
+ tmp = gfc_evaluate_now (tmp, block);
tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
- tmp4 = fill_with_spaces (tmp4, chartype,
- fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE(dlen), dlen, slen));
+ tmp4 = fill_with_spaces (tmp4, chartype, tmp);
gfc_init_block (&tempblock);
- gfc_add_expr_to_block (&tempblock, tmp3);
gfc_add_expr_to_block (&tempblock, tmp4);
tmp3 = gfc_finish_block (&tempblock);
/* The whole copy_string function is there. */
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
- tmp2, tmp3);
+ tmp3, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&tmpblock2, tmp);
+ tmp = gfc_finish_block (&tmpblock2);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
{
gfc_se se;
+ if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
+ && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ return build_constructor (type, NULL);
+
if (!(expr || pointer || procptr))
return NULL_TREE;
{
switch (ts->type)
{
- case BT_DERIVED:
+ case_bt_struct:
case BT_CLASS:
gfc_init_se (&se, NULL);
if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
gfc_add_modify (&block, dest, se.expr);
/* Deal with arrays of derived types with allocatable components. */
- if (cm->ts.type == BT_DERIVED
+ if (gfc_bt_struct (cm->ts.type)
&& cm->ts.u.derived->attr.alloc_comp)
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
se.expr, dest,
- cm->as->rank);
+ cm->as->rank, 0);
else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
&& CLASS_DATA(cm)->attr.allocatable)
{
if (cm->ts.u.derived->attr.alloc_comp)
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
se.expr, dest,
- expr->rank);
+ expr->rank, 0);
else
{
tmp = TREE_TYPE (dest);
/* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
component. */
sprintf (name, "_%s_length", cm->name);
- strlen = gfc_find_component (sym, name, true, true);
+ strlen = gfc_find_component (sym, name, true, true, NULL);
lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
gfc_charlen_type_node,
TREE_OPERAND (comp, 0),
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- else if (cm->attr.allocatable)
+ else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
gfc_add_expr_to_block (&block, tmp);
}
+ else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
+ {
+ /* NULL initialization for allocatable components. */
+ gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
+ null_pointer_node));
+ }
else if (init && (cm->attr.allocatable
|| (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
&& expr->ts.type != BT_CLASS)))
fold_convert (TREE_TYPE (tmp), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
+ else if (expr->ts.type == BT_UNION)
+ {
+ tree tmp;
+ gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
+ /* We mark that the entire union should be initialized with a contrived
+ EXPR_NULL expression at the beginning. */
+ if (c != NULL && c->n.component == NULL
+ && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
+ {
+ tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ dest, build_constructor (TREE_TYPE (dest), NULL));
+ gfc_add_expr_to_block (&block, tmp);
+ c = gfc_constructor_next (c);
+ }
+ /* The following constructor expression, if any, represents a specific
+ map intializer, as given by the user. */
+ if (c != NULL && c->expr != NULL)
+ {
+ gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+ tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ }
else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
{
if (expr->expr_type != EXPR_STRUCTURE)
if (cm->ts.u.derived->attr.alloc_comp
&& expr->expr_type != EXPR_NULL)
{
+ // TODO: Fix caf_mode
tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
- dest, expr->rank);
+ dest, expr->rank, 0);
gfc_add_expr_to_block (&block, tmp);
if (dealloc != NULL_TREE)
gfc_add_expr_to_block (&block, dealloc);
/* Assign a derived type constructor to a variable. */
tree
-gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init)
+gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
{
gfc_constructor *c;
gfc_component *cm;
stmtblock_t block;
tree field;
tree tmp;
+ gfc_se se;
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
&& (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
|| expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
{
- gfc_se se, lse;
+ gfc_se lse;
- gcc_assert (cm->backend_decl == NULL);
gfc_init_se (&se, NULL);
gfc_init_se (&lse, NULL);
gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
return gfc_finish_block (&block);
}
+ if (coarray)
+ gfc_init_se (&se, NULL);
+
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
{
if (!c->expr && !cm->attr.allocatable)
continue;
+ /* Register the component with the caf-lib before it is initialized.
+ Register only allocatable components, that are not coarray'ed
+ components (%comp[*]). Only register when the constructor is not the
+ null-expression. */
+ if (coarray && !cm->attr.codimension
+ && (cm->attr.allocatable || cm->attr.pointer)
+ && (!c->expr || c->expr->expr_type == EXPR_NULL))
+ {
+ tree token, desc, size;
+ bool is_array = cm->ts.type == BT_CLASS
+ ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
+
+ field = cm->backend_decl;
+ field = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), dest, field, NULL_TREE);
+ if (cm->ts.type == BT_CLASS)
+ field = gfc_class_data_get (field);
+
+ token = is_array ? gfc_conv_descriptor_token (field)
+ : fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (cm->caf_token), dest,
+ cm->caf_token, NULL_TREE);
+
+ if (is_array)
+ {
+ /* The _caf_register routine looks at the rank of the array
+ descriptor to decide whether the data registered is an array
+ or not. */
+ int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
+ : cm->as->rank;
+ /* When the rank is not known just set a positive rank, which
+ suffices to recognize the data as array. */
+ if (rank < 0)
+ rank = 1;
+ size = integer_zero_node;
+ desc = field;
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
+ build_int_cst (gfc_array_index_type, rank));
+ }
+ else
+ {
+ desc = gfc_conv_scalar_to_descriptor (&se, field,
+ cm->ts.type == BT_CLASS
+ ? CLASS_DATA (cm)->attr
+ : cm->attr);
+ size = TYPE_SIZE_UNIT (TREE_TYPE (field));
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
+ 7, size, build_int_cst (
+ integer_type_node,
+ GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
+ gfc_build_addr_expr (pvoid_type_node,
+ token),
+ gfc_build_addr_expr (NULL_TREE, desc),
+ null_pointer_node, null_pointer_node,
+ integer_zero_node);
+ gfc_add_expr_to_block (&block, tmp);
+ }
field = cm->backend_decl;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
return gfc_finish_block (&block);
}
+void
+gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
+ gfc_component *un, gfc_expr *init)
+{
+ gfc_constructor *ctor;
+
+ if (un->ts.type != BT_UNION || un == NULL || init == NULL)
+ return;
+
+ ctor = gfc_constructor_first (init->value.constructor);
+
+ if (ctor == NULL || ctor->expr == NULL)
+ return;
+
+ gcc_assert (init->expr_type == EXPR_STRUCTURE);
+
+ /* If we have an 'initialize all' constructor, do it first. */
+ if (ctor->expr->expr_type == EXPR_NULL)
+ {
+ tree union_type = TREE_TYPE (un->backend_decl);
+ tree val = build_constructor (union_type, NULL);
+ CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+ ctor = gfc_constructor_next (ctor);
+ }
+
+ /* Add the map initializer on top. */
+ if (ctor != NULL && ctor->expr != NULL)
+ {
+ gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
+ tree val = gfc_conv_initializer (ctor->expr, &un->ts,
+ TREE_TYPE (un->backend_decl),
+ un->attr.dimension, un->attr.pointer,
+ un->attr.proc_pointer);
+ CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
+ }
+}
+
/* Build an expression for a constructor. If init is nonzero then
this is part of a static variable initializer. */
se->expr = gfc_create_var (type, expr->ts.u.derived->name);
/* The symtree in expr is NULL, if the code to generate is for
initializing the static members only. */
- tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL);
+ tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
+ se->want_coarray);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
fold_convert (TREE_TYPE (cm->backend_decl),
integer_zero_node));
+ else if (cm->ts.type == BT_UNION)
+ gfc_conv_union_initializer (v, cm, c->expr);
else
{
val = gfc_conv_initializer (c->expr, &cm->ts,
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
}
}
+
se->expr = build_constructor (type, v);
if (init)
TREE_CONSTANT (se->expr) = 1;
}
+/* Get the _len component for an unlimited polymorphic expression. */
+
+static tree
+trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
+{
+ gfc_se se;
+ gfc_ref *ref = expr->ref;
+
+ gfc_init_se (&se, NULL);
+ while (ref && ref->next)
+ ref = ref->next;
+ gfc_add_len_component (expr);
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ if (ref)
+ {
+ gfc_free_ref_list (ref->next);
+ ref->next = NULL;
+ }
+ else
+ {
+ gfc_free_ref_list (expr->ref);
+ expr->ref = NULL;
+ }
+ return se.expr;
+}
+
+
+/* Assign _vptr and _len components as appropriate. BLOCK should be a
+ statement-list outside of the scalarizer-loop. When code is generated, that
+ depends on the scalarized expression, it is added to RSE.PRE.
+ Returns le's _vptr tree and when set the len expressions in to_lenp and
+ from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
+ expression. */
+
+static tree
+trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
+ gfc_expr * re, gfc_se *rse,
+ tree * to_lenp, tree * from_lenp)
+{
+ gfc_se se;
+ gfc_expr * vptr_expr;
+ tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
+ bool set_vptr = false, temp_rhs = false;
+ stmtblock_t *pre = block;
+
+ /* Create a temporary for complicated expressions. */
+ if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
+ && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ pre = &rse->pre;
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ rse->expr = tmp;
+ temp_rhs = true;
+ }
+
+ /* Get the _vptr for the left-hand side expression. */
+ gfc_init_se (&se, NULL);
+ vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
+ if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
+ {
+ /* Care about _len for unlimited polymorphic entities. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ to_len = trans_get_upoly_len (block, vptr_expr);
+ gfc_add_vptr_component (vptr_expr);
+ set_vptr = true;
+ }
+ else
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ lhs_vptr = se.expr;
+ STRIP_NOPS (lhs_vptr);
+
+ /* Set the _vptr only when the left-hand side of the assignment is a
+ class-object. */
+ if (set_vptr)
+ {
+ /* Get the vptr from the rhs expression only, when it is variable.
+ Functions are expected to be assigned to a temporary beforehand. */
+ vptr_expr = re->expr_type == EXPR_VARIABLE
+ ? gfc_find_and_cut_at_last_class_ref (re)
+ : NULL;
+ if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
+ {
+ if (to_len != NULL_TREE)
+ {
+ /* Get the _len information from the rhs. */
+ if (UNLIMITED_POLY (vptr_expr)
+ || (vptr_expr->ts.type == BT_DERIVED
+ && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
+ from_len = trans_get_upoly_len (block, vptr_expr);
+ }
+ gfc_add_vptr_component (vptr_expr);
+ }
+ else
+ {
+ if (re->expr_type == EXPR_VARIABLE
+ && DECL_P (re->symtree->n.sym->backend_decl)
+ && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
+ && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl))))
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ if (to_len)
+ from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
+ re->symtree->n.sym->backend_decl));
+ }
+ else if (temp_rhs && re->ts.type == BT_CLASS)
+ {
+ vptr_expr = NULL;
+ se.expr = gfc_class_vptr_get (rse->expr);
+ }
+ else if (re->expr_type != EXPR_NULL)
+ /* Only when rhs is non-NULL use its declared type for vptr
+ initialisation. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
+ else
+ /* When the rhs is NULL use the vtab of lhs' declared type. */
+ vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
+ }
+
+ if (vptr_expr)
+ {
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, vptr_expr);
+ gfc_free_expr (vptr_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ }
+ gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
+ se.expr));
+
+ if (to_len != NULL_TREE)
+ {
+ /* The _len component needs to be set. Figure how to get the
+ value of the right-hand side. */
+ if (from_len == NULL_TREE)
+ {
+ if (rse->string_length != NULL_TREE)
+ from_len = rse->string_length;
+ else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
+ {
+ from_len = gfc_get_expr_charlen (re);
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, re->ts.u.cl->length);
+ gfc_add_block_to_block (block, &se.pre);
+ gcc_assert (se.post.head == NULL_TREE);
+ from_len = gfc_evaluate_now (se.expr, block);
+ }
+ else
+ from_len = integer_zero_node;
+ }
+ gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
+ from_len));
+ }
+ }
+
+ /* Return the _len trees only, when requested. */
+ if (to_lenp)
+ *to_lenp = to_len;
+ if (from_lenp)
+ *from_lenp = from_len;
+ return lhs_vptr;
+}
+
+
+/* Assign tokens for pointer components. */
+
+static void
+trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
+ gfc_expr *expr2)
+{
+ symbol_attribute lhs_attr, rhs_attr;
+ tree tmp, lhs_tok, rhs_tok;
+ /* Flag to indicated component refs on the rhs. */
+ bool rhs_cr;
+
+ lhs_attr = gfc_caf_attr (expr1);
+ if (expr2->expr_type != EXPR_NULL)
+ {
+ rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
+ if (lhs_attr.codimension && rhs_attr.codimension)
+ {
+ lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+ lhs_tok = build_fold_indirect_ref (lhs_tok);
+
+ if (rhs_cr)
+ rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
+ else
+ {
+ tree caf_decl;
+ caf_decl = gfc_get_tree_for_caf_expr (expr2);
+ gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
+ NULL_TREE, NULL);
+ }
+ tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ lhs_tok,
+ fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
+ gfc_prepend_expr_to_block (&lse->post, tmp);
+ }
+ }
+ else if (lhs_attr.codimension)
+ {
+ lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+ lhs_tok = build_fold_indirect_ref (lhs_tok);
+ tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ lhs_tok, null_pointer_node);
+ gfc_prepend_expr_to_block (&lse->post, tmp);
+ }
+}
+
+/* Indentify class valued proc_pointer assignments. */
+
+static bool
+pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
+{
+ gfc_ref * ref;
+
+ ref = expr1->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+
+ return ref && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
+}
+
+
tree
gfc_trans_pointer_assign (gfc_code * code)
{
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
- gfc_expr *expr1_vptr = NULL;
gfc_se lse;
gfc_se rse;
stmtblock_t block;
tree desc;
tree tmp;
tree decl;
- bool scalar;
+ bool scalar, non_proc_pointer_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
+ /* Usually testing whether this is not a proc pointer assignment. */
+ non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
ss = gfc_walk_expr (expr1);
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+ if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ {
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
+ NULL);
+ lse.expr = gfc_class_data_get (lse.expr);
+ }
+
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
lse.expr = build_fold_indirect_ref_loc (input_location,
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
- /* For string assignments to unlimited polymorphic pointers add an
- assignment of the string_length to the _len component of the
- pointer. */
- if ((expr1->ts.type == BT_CLASS || expr1->ts.type == BT_DERIVED)
- && expr1->ts.u.derived->attr.unlimited_polymorphic
- && (expr2->ts.type == BT_CHARACTER ||
- ((expr2->ts.type == BT_DERIVED || expr2->ts.type == BT_CLASS)
- && expr2->ts.u.derived->attr.unlimited_polymorphic)))
- {
- gfc_expr *len_comp;
- gfc_se se;
- len_comp = gfc_get_len_component (expr1);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, len_comp);
-
- /* ptr % _len = len (str) */
- gfc_add_modify (&block, se.expr, rse.string_length);
- lse.string_length = se.expr;
- gfc_free_expr (len_comp);
- }
-
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. Exclude deferred
character length lefthand sides. */
build_int_cst (gfc_charlen_type_node, 0));
}
- if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS)
- rse.expr = gfc_class_data_get (rse.expr);
-
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
+ /* Also set the tokens for pointer components in derived typed
+ coarrays. */
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ trans_caf_token_assign (&lse, &rse, expr1, expr2);
+
gfc_add_block_to_block (&block, &rse.post);
gfc_add_block_to_block (&block, &lse.post);
}
{
gfc_ref* remap;
bool rank_remap;
+ tree expr1_vptr = NULL_TREE;
tree strlen_lhs;
tree strlen_rhs = NULL_TREE;
gfc_init_se (&lse, NULL);
if (remap)
lse.descriptor_only = 1;
- if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS
- && expr1->ts.type == BT_CLASS)
- expr1_vptr = gfc_copy_expr (expr1);
gfc_conv_expr_descriptor (&lse, expr1);
strlen_lhs = lse.string_length;
desc = lse.expr;
rse.expr = gfc_class_data_get (rse.expr);
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
}
bound, bound, 0,
GFC_ARRAY_POINTER_CONT, false);
tmp = gfc_create_var (tmp, "ptrtemp");
- lse.descriptor_only = 0;
- lse.expr = tmp;
- lse.direct_byref = 1;
- gfc_conv_expr_descriptor (&lse, expr2);
- strlen_rhs = lse.string_length;
+ rse.descriptor_only = 0;
+ rse.expr = tmp;
+ rse.direct_byref = 1;
+ gfc_conv_expr_descriptor (&rse, expr2);
+ strlen_rhs = rse.string_length;
rse.expr = tmp;
}
else
{
gfc_conv_expr_descriptor (&rse, expr2);
strlen_rhs = rse.string_length;
+ if (expr1->ts.type == BT_CLASS)
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse,
+ NULL, NULL);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
gfc_init_se (&rse, NULL);
rse.descriptor_only = 1;
gfc_conv_expr (&rse, expr2);
+ if (expr1->ts.type == BT_CLASS)
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
if (!INTEGER_CST_P (tmp))
gfc_add_block_to_block (&lse.post, &rse.pre);
gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
}
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ rse.expr = NULL_TREE;
+ rse.string_length = NULL_TREE;
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
+ NULL, NULL);
+ }
}
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
{
}
else
{
+ expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
+ expr2, &rse, NULL,
+ NULL);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
- gfc_add_vptr_component (expr1_vptr);
- gfc_init_se (&rse, NULL);
- rse.want_pointer = 1;
- gfc_conv_expr (&rse, expr1_vptr);
- gfc_add_modify (&lse.pre, rse.expr,
- fold_convert (TREE_TYPE (rse.expr),
+ gfc_add_modify (&lse.pre, expr1_vptr,
+ fold_convert (TREE_TYPE (expr1_vptr),
gfc_class_vptr_get (tmp)));
rse.expr = gfc_class_data_get (tmp);
gfc_add_modify (&lse.pre, desc, rse.expr);
gfc_add_modify (&lse.pre, desc, tmp);
}
- if (expr1_vptr)
- gfc_free_expr (expr1_vptr);
-
gfc_add_block_to_block (&block, &lse.pre);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.pre);
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool deep_copy, bool dealloc)
+ bool deep_copy, bool dealloc, bool in_coarray)
{
stmtblock_t block;
tree tmp;
if (rse->string_length != NULL_TREE)
{
- gcc_assert (rse->string_length != NULL_TREE);
gfc_conv_string_parameter (rse);
gfc_add_block_to_block (&block, &rse->pre);
rlen = rse->string_length;
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
+ else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
{
tree tmp_var = NULL_TREE;
cond = NULL_TREE;
same as the lhs. */
if (deep_copy)
{
- tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
+ int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+ | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
+ tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
+ caf_mode);
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+ else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
/* Tells whether the expression is to be treated as a variable reference. */
-static bool
-expr_is_variable (gfc_expr *expr)
+bool
+gfc_expr_is_variable (gfc_expr *expr)
{
gfc_expr *arg;
gfc_component *comp;
if (arg)
{
gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
- return expr_is_variable (arg);
+ return gfc_expr_is_variable (arg);
}
/* A data-pointer-returning function should be considered as a variable
&& !expr->ref)
return true;
- /* All that can be left are allocatable components. */
- if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+ /* All that can be left are allocatable components. However, we do
+ not check for allocatable components here because the expression
+ could be an allocatable component of a pointer component. */
+ if (expr->symtree->n.sym->ts.type != BT_DERIVED
&& expr->symtree->n.sym->ts.type != BT_CLASS)
- || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
return false;
/* Find an allocatable component ref last. */
size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size_in_bytes, size_one_node);
- if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
+ if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ tree caf_decl, token;
+ gfc_se caf_se;
+ symbol_attribute attr;
+
+ gfc_clear_attr (&attr);
+ gfc_init_se (&caf_se, NULL);
+
+ caf_decl = gfc_get_tree_for_caf_expr (expr1);
+ gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
+ NULL);
+ gfc_add_block_to_block (block, &caf_se.pre);
+ gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
+ gfc_build_addr_expr (NULL_TREE, token),
+ NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
+ expr1, 1);
+ }
+ else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
{
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_CALLOC),
return false;
}
+
+static tree
+trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
+ gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
+ bool class_realloc)
+{
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr;
+ vec<tree, va_gc> *args = NULL;
+
+ vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+ &from_len);
+
+ /* Generate allocation of the lhs. */
+ if (class_realloc)
+ {
+ stmtblock_t alloc;
+ tree class_han;
+
+ tmp = gfc_vptr_size_get (vptr);
+ class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ gfc_init_block (&alloc);
+ gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, class_han,
+ build_int_cst (prvoid_type_node, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_unlikely (tmp,
+ PRED_FORTRAN_FAIL_ALLOC),
+ gfc_finish_block (&alloc),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&lse->pre, tmp);
+ }
+
+ fcn = gfc_vptr_copy_get (vptr);
+
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+ ? gfc_class_data_get (rse->expr) : rse->expr;
+ if (use_vptr_copy)
+ {
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (rhs->ts.type == BT_DERIVED
+ && rhs->ts.u.derived->attr.unlimited_polymorphic
+ && !rhs->ts.u.derived->attr.pointer
+ && !rhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (rhs)
+ && !CLASS_DATA (rhs)->attr.pointer
+ && !CLASS_DATA (rhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+ tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp))
+ || INDIRECT_REF_P (tmp)
+ || (lhs->ts.type == BT_DERIVED
+ && lhs->ts.u.derived->attr.unlimited_polymorphic
+ && !lhs->ts.u.derived->attr.pointer
+ && !lhs->ts.u.derived->attr.allocatable)
+ || (UNLIMITED_POLY (lhs)
+ && !CLASS_DATA (lhs)->attr.pointer
+ && !CLASS_DATA (lhs)->attr.allocatable))
+ vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
+ else
+ vec_safe_push (args, tmp);
+
+ stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ if (to_len != NULL_TREE && !integer_zerop (from_len))
+ {
+ tree extcopy;
+ vec_safe_push (args, from_len);
+ vec_safe_push (args, to_len);
+ extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
+
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, from_len,
+ integer_zero_node);
+ return fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ extcopy, stdcopy);
+ }
+ else
+ return stdcopy;
+ }
+ else
+ {
+ tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ ? gfc_class_data_get (lse->expr) : lse->expr;
+ stmtblock_t tblock;
+ gfc_init_block (&tblock);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
+ rhst = gfc_build_addr_expr (NULL_TREE, rhst);
+ /* When coming from a ptr_copy lhs and rhs are swapped. */
+ gfc_add_modify_loc (input_location, &tblock, rhst,
+ fold_convert (TREE_TYPE (rhst), tmp));
+ return gfc_finish_block (&tblock);
+ }
+}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
- deallocate prior assignment is needed (if in doubt, set true). */
+ deallocate prior assignment is needed (if in doubt, set true).
+ When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
+ routine instead of a pointer assignment. Alias resolution is only done,
+ when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
+ where it is known, that newly allocated memory on the lhs can never be
+ an alias of the rhs. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
gfc_se lse;
gfc_se rse;
bool scalar_to_array;
tree string_length;
int n;
+ bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
+ symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
+ bool is_poly_assign;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
|| gfc_is_alloc_class_scalar_function (expr2)))
expr2->must_finalize = 1;
+ /* Checking whether a class assignment is desired is quite complicated and
+ needed at two locations, so do it once only before the information is
+ needed. */
+ lhs_attr = gfc_expr_attr (expr1);
+ is_poly_assign = (use_vptr_copy || lhs_attr.pointer
+ || (lhs_attr.allocatable && !lhs_attr.dimension))
+ && (expr1->ts.type == BT_CLASS
+ || gfc_is_class_array_ref (expr1, NULL)
+ || gfc_is_class_scalar_expr (expr1)
+ || gfc_is_class_array_ref (expr2, NULL)
+ || gfc_is_class_scalar_expr (expr2));
+
+
+ /* Only analyze the expressions for coarray properties, when in coarray-lib
+ mode. */
+ if (flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
+ rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
+ }
+
if (lss != gfc_ss_terminator)
{
/* The assignment needs scalarization. */
if (rss == gfc_ss_terminator)
/* The rhs is scalar. Add a ss for the expression. */
rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ /* When doing a class assign, then the handle to the rhs needs to be a
+ pointer to allow for polymorphism. */
+ if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
+ rss->info->type = GFC_SS_REFERENCE;
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
- gfc_conv_resolve_dependencies (&loop, lss, rss);
+ if (may_alias)
+ gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where);
}
/* Allow the scalarizer to workshare array assignments. */
- if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
- ompws_flags |= OMPWS_SCALARIZER_WS;
+ if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
+ == OMPWS_WORKSHARE_FLAG
+ && loop.temp_ss == NULL)
+ {
+ maybe_workshare = true;
+ ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
+ }
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
/* Translate the expression. */
+ rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
+ && lhs_caf_attr.codimension;
gfc_conv_expr (&rse, expr2);
/* Deal with the case of a scalar class function assigned to a derived type. */
}
/* Stabilize a string length for temporaries. */
- if (expr2->ts.type == BT_CHARACTER)
+ if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
+ && !(VAR_P (rse.string_length)
+ || TREE_CODE (rse.string_length) == PARM_DECL
+ || TREE_CODE (rse.string_length) == INDIRECT_REF))
string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ else if (expr2->ts.type == BT_CHARACTER)
+ string_length = rse.string_length;
else
string_length = NULL_TREE;
lse.string_length = string_length;
}
else
- gfc_conv_expr (&lse, expr1);
+ {
+ gfc_conv_expr (&lse, expr1);
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEM
+ && !init_flag
+ && gfc_expr_attr (expr1).allocatable
+ && expr1->rank
+ && !expr2->rank)
+ {
+ tree cond;
+ const char* msg;
+
+ tmp = INDIRECT_REF_P (lse.expr)
+ ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
+
+ /* We should only get array references here. */
+ gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
+ || TREE_CODE (tmp) == ARRAY_REF);
+
+ /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
+ or the array itself(ARRAY_REF). */
+ tmp = TREE_OPERAND (tmp, 0);
+
+ /* Provide the address of the array. */
+ if (TREE_CODE (lse.expr) == ARRAY_REF)
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ msg = _("Assignment of scalar to unallocated array");
+ gfc_trans_runtime_check (true, false, cond, &loop.pre,
+ &expr1->where, msg);
+ }
+ }
/* Assignments of scalar derived types with allocatable components
to arrays must be done with a deep copy and the rhs temporary
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
&& expr2->ts.u.derived->attr.alloc_comp
- && !expr_is_variable (expr2)
+ && !gfc_expr_is_variable (expr2)
&& expr1->rank && !expr2->rank);
scalar_to_array |= (expr1->ts.type == BT_DERIVED
&& expr1->rank
the function call must happen before the (re)allocation of the lhs -
otherwise the character length of the result is not known.
NOTE: This relies on having the exact dependence of the length type
- parameter available to the caller; gfortran saves it in the .mod files. */
- if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ parameter available to the caller; gfortran saves it in the .mod files.
+ NOTE ALSO: The concatenation operation generates a temporary pointer,
+ whose allocation must go to the innermost loop. */
+ if (flag_realloc_lhs
+ && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
+ && !(lss != gfc_ss_terminator
+ && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT))
gfc_add_block_to_block (&block, &rse.pre);
/* Nullify the allocatable components corresponding to those of the lhs
nullification occurs before the call to the finalizer. In the case of
a scalar to array assignment, this is done in gfc_trans_scalar_assign
as part of the deep copy. */
- if (!scalar_to_array && (expr1->ts.type == BT_DERIVED)
- && (gfc_is_alloc_class_array_function (expr2)
- || gfc_is_alloc_class_scalar_function (expr2)))
+ if (!scalar_to_array && expr1->ts.type == BT_DERIVED
+ && (gfc_is_alloc_class_array_function (expr2)
+ || gfc_is_alloc_class_scalar_function (expr2)))
{
tmp = rse.expr;
tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
gfc_add_block_to_block (&loop.post, &rse.post);
}
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- expr_is_variable (expr2) || scalar_to_array
- || expr2->expr_type == EXPR_ARRAY,
- !(l_is_temp || init_flag) && dealloc);
+ if (is_poly_assign)
+ tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+ use_vptr_copy || (lhs_attr.allocatable
+ && !lhs_attr.dimension),
+ flag_realloc_lhs && !lhs_attr.pointer);
+ else if (flag_coarray == GFC_FCOARRAY_LIB
+ && lhs_caf_attr.codimension && rhs_caf_attr.codimension
+ && ((lhs_caf_attr.allocatable && lhs_refs_comp)
+ || (rhs_caf_attr.allocatable && rhs_refs_comp)))
+ {
+ /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
+ allocatable component, because those need to be accessed via the
+ caf-runtime. No need to check for coindexes here, because resolve
+ has rewritten those already. */
+ gfc_code code;
+ gfc_actual_arglist a1, a2;
+ /* Clear the structures to prevent accessing garbage. */
+ memset (&code, '\0', sizeof (gfc_code));
+ memset (&a1, '\0', sizeof (gfc_actual_arglist));
+ memset (&a2, '\0', sizeof (gfc_actual_arglist));
+ a1.expr = expr1;
+ a1.next = &a2;
+ a2.expr = expr2;
+ a2.next = NULL;
+ code.ext.actual = &a1;
+ code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+ tmp = gfc_conv_intrinsic_subroutine (&code);
+ }
+ else
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ gfc_expr_is_variable (expr2)
+ || scalar_to_array
+ || expr2->expr_type == EXPR_ARRAY,
+ !(l_is_temp || init_flag) && dealloc,
+ expr1->symtree->n.sym->attr.codimension);
+ /* Add the pre blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
+ /* Add the post blocks to the body. */
+ gfc_add_block_to_block (&body, &rse.post);
+ gfc_add_block_to_block (&body, &lse.post);
if (lss == gfc_ss_terminator)
{
/* F2003: Add the code for reallocation on assignment. */
- if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
+ if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
+ && !is_poly_assign)
alloc_scalar_allocatable_for_assignment (&block, string_length,
expr1, expr2);
/* F2003: Allocate or reallocate lhs of allocatable array. */
if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && !gfc_expr_attr (expr1).codimension
- && !gfc_is_coindexed (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2))
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2))
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
}
+ if (maybe_workshare)
+ ompws_flags &= ~OMPWS_SCALARIZER_BODY;
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
case BT_CHARACTER:
return false;
- case BT_DERIVED:
+ case_bt_struct:
return !expr->ts.u.derived->attr.alloc_comp;
default:
tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
- bool dealloc)
+ bool dealloc, bool use_vptr_copy, bool may_alias)
{
tree tmp;
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
+ use_vptr_copy, may_alias);
}
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, true, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
}
tree
projects / gcc.git / blobdiff