Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / fortran / trans-expr.cc
blob: 850007fd2e14da21c39e075d55904a25627e552e [file] [log] [blame]
/* Expression translation
Copyright (C) 2002-2022 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "tree.h"
#include "gfortran.h"
#include "trans.h"
#include "stringpool.h"
#include "diagnostic-core.h" /* For fatal_error. */
#include "fold-const.h"
#include "langhooks.h"
#include "arith.h"
#include "constructor.h"
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
#include "dependency.h"
#include "gimplify.h"
#include "tm.h" /* For CHAR_TYPE_SIZE. */
/* Calculate the number of characters in a string. */
static tree
gfc_get_character_len (tree type)
{
tree len;
gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_STRING_FLAG (type));
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
len = (len) ? (len) : (integer_zero_node);
return fold_convert (gfc_charlen_type_node, len);
}
/* Calculate the number of bytes in a string. */
tree
gfc_get_character_len_in_bytes (tree type)
{
tree tmp, len;
gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_STRING_FLAG (type));
tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
len = gfc_get_character_len (type);
if (tmp && len && !integer_zerop (len))
len = fold_build2_loc (input_location, MULT_EXPR,
gfc_charlen_type_node, len, tmp);
return len;
}
/* Convert a scalar to an array descriptor. To be used for assumed-rank
arrays. */
static tree
get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
{
enum gfc_array_kind akind;
if (attr.pointer)
akind = GFC_ARRAY_POINTER_CONT;
else if (attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
else
akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
if (POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = TREE_TYPE (scalar);
return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
akind, !(attr.pointer || attr.target));
}
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
tree desc, type, etype;
type = get_scalar_to_descriptor_type (scalar, attr);
etype = TREE_TYPE (scalar);
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);
else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
etype = TREE_TYPE (etype);
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype_rank_type (0, etype));
gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
gfc_conv_descriptor_span_set (&se->pre, desc,
gfc_conv_descriptor_elem_len (desc));
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
gfc_add_modify (&se->post, scalar,
fold_convert (TREE_TYPE (scalar),
gfc_conv_descriptor_data_get (desc)));
return 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
in future implementations. Use the corresponding APIs. */
#define CLASS_DATA_FIELD 0
#define CLASS_VPTR_FIELD 1
#define CLASS_LEN_FIELD 2
#define VTABLE_HASH_FIELD 0
#define VTABLE_SIZE_FIELD 1
#define VTABLE_EXTENDS_FIELD 2
#define VTABLE_DEF_INIT_FIELD 3
#define VTABLE_COPY_FIELD 4
#define VTABLE_FINAL_FIELD 5
#define VTABLE_DEALLOCATE_FIELD 6
tree
gfc_class_set_static_fields (tree decl, tree vptr, tree data)
{
tree tmp;
tree field;
vec<constructor_elt, va_gc> *init = NULL;
field = TYPE_FIELDS (TREE_TYPE (decl));
tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp, data);
tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
return build_constructor (TREE_TYPE (decl), init);
}
tree
gfc_class_data_get (tree decl)
{
tree data;
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_DATA_FIELD);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (data), decl, data,
NULL_TREE);
}
tree
gfc_class_vptr_get (tree decl)
{
tree vptr;
/* 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);
vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_VPTR_FIELD);
return fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (vptr), decl, vptr,
NULL_TREE);
}
tree
gfc_class_len_get (tree decl)
{
tree len;
/* For class arrays decl may be a temporary descriptor handle, the len 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 fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (len), decl, len,
NULL_TREE);
}
/* 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. */
static 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)
: build_zero_cst (gfc_charlen_type_node);
}
tree
gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
{
tree tmp;
tree tmp2;
tree type;
tmp = gfc_class_len_or_zero_get (class_expr);
/* Include the len value in the element size if present. */
if (!integer_zerop (tmp))
{
type = TREE_TYPE (size);
if (block)
{
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, tmp,
build_zero_cst (type));
size = fold_build3_loc (input_location, COND_EXPR,
type, tmp, tmp2, size);
}
else
return size;
if (block)
size = gfc_evaluate_now (size, block);
return size;
}
/* Get the specified FIELD from the VPTR. */
static tree
vptr_field_get (tree vptr, int fieldno)
{
tree field;
vptr = build_fold_indirect_ref_loc (input_location, vptr);
field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
fieldno);
field = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), vptr, field,
NULL_TREE);
gcc_assert (field);
return field;
}
/* Get the field from the class' vptr. */
static tree
class_vtab_field_get (tree decl, int fieldno)
{
tree vptr;
vptr = gfc_class_vptr_get (decl);
return vptr_field_get (vptr, fieldno);
}
/* Define a macro for creating the class_vtab_* and vptr_* accessors in
unison. */
#define VTAB_GET_FIELD_GEN(name, field) tree \
gfc_class_vtab_## name ##_get (tree cl) \
{ \
return class_vtab_field_get (cl, field); \
} \
\
tree \
gfc_vptr_## name ##_get (tree vptr) \
{ \
return vptr_field_get (vptr, field); \
}
VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
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)
#undef VTAB_GET_FIELD_GEN
/* The size field is returned as an array index type. Therefore treat
it and only it specially. */
tree
gfc_class_vtab_size_get (tree cl)
{
tree size;
size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
/* Always return size as an array index type. */
size = fold_convert (gfc_array_index_type, size);
gcc_assert (size);
return size;
}
tree
gfc_vptr_size_get (tree vptr)
{
tree size;
size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
/* Always return size as an array index type. */
size = fold_convert (gfc_array_index_type, size);
gcc_assert (size);
return size;
}
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_FIELD
#undef CLASS_LEN_FIELD
#undef VTABLE_HASH_FIELD
#undef VTABLE_SIZE_FIELD
#undef VTABLE_EXTENDS_FIELD
#undef VTABLE_DEF_INIT_FIELD
#undef VTABLE_COPY_FIELD
#undef VTABLE_FINAL_FIELD
/* 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.cc: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.cc: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_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;
if (ts)
{
if (e->symtree
&& e->symtree->n.sym->ts.type == BT_CLASS)
*ts = &e->symtree->n.sym->ts;
else
*ts = NULL;
}
for (ref = e->ref; ref; ref = ref->next)
{
if (ts)
{
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->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)
{
tail = class_ref->next;
class_ref->next = NULL;
}
else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
tail = e->ref;
e->ref = NULL;
}
if (is_mold)
base_expr = gfc_expr_to_initialize (e);
else
base_expr = gfc_copy_expr (e);
/* Restore the original tail expression. */
if (class_ref)
{
gfc_free_ref_list (class_ref->next);
class_ref->next = tail;
}
else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
gfc_free_ref_list (e->ref);
e->ref = tail;
}
return base_expr;
}
/* Reset the vptr to the declared type, e.g. after deallocation. */
void
gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
{
gfc_symbol *vtab;
tree vptr;
tree vtable;
gfc_se se;
/* Evaluate the expression and obtain the vptr from it. */
gfc_init_se (&se, NULL);
if (e->rank)
gfc_conv_expr_descriptor (&se, e);
else
gfc_conv_expr (&se, e);
gfc_add_block_to_block (block, &se.pre);
vptr = gfc_get_vptr_from_expr (se.expr);
/* If a vptr is not found, we can do nothing more. */
if (vptr == NULL_TREE)
return;
if (UNLIMITED_POLY (e))
gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
else
{
/* Return the vptr to the address of the declared type. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
vtable = vtab->backend_decl;
if (vtable == NULL_TREE)
vtable = gfc_get_symbol_decl (vtab);
vtable = gfc_build_addr_expr (NULL, vtable);
vtable = fold_convert (TREE_TYPE (vptr), vtable);
gfc_add_modify (block, vptr, vtable);
}
}
/* Reset the len for unlimited polymorphic objects. */
void
gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
{
gfc_expr *e;
gfc_se se_len;
e = gfc_find_and_cut_at_last_class_ref (expr);
if (e == NULL)
return;
gfc_add_len_component (e);
gfc_init_se (&se_len, NULL);
gfc_conv_expr (&se_len, e);
gfc_add_modify (block, se_len.expr,
fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
gfc_free_expr (e);
}
/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
reference is found. Note that it is up to the caller to avoid using this
for expressions other than variables. */
tree
gfc_get_class_from_gfc_expr (gfc_expr *e)
{
gfc_expr *class_expr;
gfc_se cse;
class_expr = gfc_find_and_cut_at_last_class_ref (e);
if (class_expr == NULL)
return NULL_TREE;
gfc_init_se (&cse, NULL);
gfc_conv_expr (&cse, class_expr);
gfc_free_expr (class_expr);
return cse.expr;
}
/* Obtain the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
gfc_get_class_from_expr (tree expr)
{
tree tmp;
tree type;
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
{
if (CONSTANT_CLASS_P (tmp))
return NULL_TREE;
type = TREE_TYPE (tmp);
while (type)
{
if (GFC_CLASS_TYPE_P (type))
return tmp;
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
type = NULL_TREE;
}
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 tmp;
return NULL_TREE;
}
/* Obtain the vptr of the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
gfc_get_vptr_from_expr (tree expr)
{
tree tmp;
tmp = gfc_get_class_from_expr (expr);
if (tmp != NULL_TREE)
return gfc_class_vptr_get (tmp);
return NULL_TREE;
}
static void
class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
bool lhs_type)
{
tree tmp, tmp2, type;
gfc_conv_descriptor_data_set (block, lhs_desc,
gfc_conv_descriptor_data_get (rhs_desc));
gfc_conv_descriptor_offset_set (block, lhs_desc,
gfc_conv_descriptor_offset_get (rhs_desc));
gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
gfc_conv_descriptor_dtype (rhs_desc));
/* Assign the dimension as range-ref. */
tmp = gfc_get_descriptor_dimension (lhs_desc);
tmp2 = gfc_get_descriptor_dimension (rhs_desc);
type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
gfc_index_zero_node, NULL_TREE, NULL_TREE);
tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
gfc_index_zero_node, NULL_TREE, NULL_TREE);
gfc_add_modify (block, tmp, tmp2);
}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If vptr is not NULL, this is
used for the temporary class object.
optional_alloc_ptr is false when the dummy is neither allocatable
nor a pointer; that's only relevant for the optional handling.
The optional argument 'derived_array' is used to preserve the parmse
expression for deallocation of allocatable components. Assumed rank
formal arguments made this necessary. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, tree vptr, bool optional,
bool optional_alloc_ptr,
tree *derived_array)
{
gfc_symbol *vtab;
tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
int dim;
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
if (vptr != NULL_TREE)
{
/* Use the dynamic vptr. */
tmp = vptr;
}
else
{
/* In this case the vtab corresponds to the derived type and the
vptr must point to it. */
vtab = gfc_find_derived_vtab (e->ts.u.derived);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
}
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
ctree = gfc_class_data_get (var);
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
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. */
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
if (optional)
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
ss = gfc_walk_expr (e);
if (ss == gfc_ss_terminator)
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
/* Scalar to an assumed-rank array. */
if (class_ts.u.derived->components->as)
{
tree type;
type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
if (optional)
parmse->expr = build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse->expr),
cond_optional, parmse->expr,
fold_convert (TREE_TYPE (parmse->expr),
null_pointer_node));
gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
}
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
if (optional)
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
}
}
else
{
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
parmse->ss = ss;
parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
/* Detect any array references with vector subscripts. */
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
&& ref->u.ar.type != AR_ELEMENT
&& ref->u.ar.type != AR_FULL)
{
for (dim = 0; dim < ref->u.ar.dimen; dim++)
if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
break;
if (dim < ref->u.ar.dimen)
break;
}
/* Array references with vector subscripts and non-variable expressions
need be converted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
{
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
gfc_index_one_node);
}
if (e->rank != class_ts.u.derived->components->as->rank)
{
gcc_assert (class_ts.u.derived->components->as->type
== AS_ASSUMED_RANK);
if (derived_array
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
{
*derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
"array");
gfc_add_modify (&block, *derived_array , parmse->expr);
}
class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
{
if (gfc_expr_attr (e).codimension)
parmse->expr = fold_build1_loc (input_location,
VIEW_CONVERT_EXPR,
TREE_TYPE (ctree),
parmse->expr);
gfc_add_modify (&block, ctree, parmse->expr);
}
if (optional)
{
tmp = gfc_finish_block (&block);
gfc_init_block (&block);
gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
if (derived_array && *derived_array != NULL_TREE)
gfc_conv_descriptor_data_set (&block, *derived_array,
null_pointer_node);
tmp = build3_v (COND_EXPR, cond_optional, tmp,
gfc_finish_block (&block));
gfc_add_expr_to_block (&parmse->pre, tmp);
}
else
gfc_add_block_to_block (&parmse->pre, &block);
}
}
if (class_ts.u.derived->components->ts.type == BT_DERIVED
&& class_ts.u.derived->components->ts.u.derived
->attr.unlimited_polymorphic)
{
/* Take care about initializing the _len component correctly. */
ctree = gfc_class_len_get (var);
if (UNLIMITED_POLY (e))
{
gfc_expr *len;
gfc_se se;
len = gfc_find_and_cut_at_last_class_ref (e);
gfc_add_len_component (len);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, len);
if (optional)
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
cond_optional, se.expr,
fold_convert (TREE_TYPE (se.expr),
integer_zero_node));
else
tmp = se.expr;
gfc_free_expr (len);
}
else
tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
tmp));
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
if (optional && optional_alloc_ptr)
parmse->expr = build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse->expr),
cond_optional, parmse->expr,
fold_convert (TREE_TYPE (parmse->expr),
null_pointer_node));
}
/* Create a new class container, which is required as scalar coarrays
have an array descriptor while normal scalars haven't. Optionally,
NULL pointer checks are added if the argument is OPTIONAL. */
static void
class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, bool optional)
{
tree var, ctree, tmp;
stmtblock_t block;
gfc_ref *ref;
gfc_ref *class_ref;
gfc_init_block (&block);
class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS)
class_ref = ref;
}
if (class_ref == NULL
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
tmp = e->symtree->n.sym->backend_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, e);
class_ref->next = ref;
tmp = tmpse.expr;
}
var = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (var, "class");
ctree = gfc_class_vptr_get (var);
gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
ctree = gfc_class_data_get (var);
tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
if (optional)
{
tree cond = gfc_conv_expr_present (e->symtree->n.sym);
tree tmp2;
tmp = gfc_finish_block (&block);
gfc_init_block (&block);
tmp2 = gfc_class_data_get (var);
gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
null_pointer_node));
tmp2 = gfc_finish_block (&block);
tmp = build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp, tmp2);
gfc_add_expr_to_block (&parmse->pre, tmp);
}
else
gfc_add_block_to_block (&parmse->pre, &block);
}
/* Takes an intrinsic type expression and returns the address of a temporary
class object of the 'declared' type. */
void
gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts)
{
gfc_symbol *vtab;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
int dim;
/* The intrinsic type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
vtab = gfc_find_vtab (&e->ts);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
ctree = gfc_class_data_get (var);
if (parmse->ss && 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. */
gfc_conv_expr_reference (parmse, e);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
ss = gfc_walk_expr (e);
if (ss == gfc_ss_terminator)
{
parmse->ss = NULL;
gfc_conv_expr_reference (parmse, e);
if (class_ts.u.derived->components->as
&& class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
{
tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
gfc_expr_attr (e));
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (ctree), tmp);
}
else
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
parmse->ss = ss;
parmse->use_offset = 1;
gfc_conv_expr_descriptor (parmse, e);
/* Array references with vector subscripts and non-variable expressions
need be converted to a one-based descriptor. */
if (e->expr_type != EXPR_VARIABLE)
{
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
dim, gfc_index_one_node);
}
if (class_ts.u.derived->components->as->rank != e->rank)
{
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
gcc_assert (class_ts.type == BT_CLASS);
if (class_ts.u.derived->components->ts.type == BT_DERIVED
&& class_ts.u.derived->components->ts.u.derived
->attr.unlimited_polymorphic)
{
ctree = gfc_class_len_get (var);
/* When the actual arg is a char array, then set the _len component of the
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
correct value more often. */
if (parmse->string_length)
tmp = parmse->string_length;
/* When the string_length is not yet set, then try the backend_decl of
the cl. */
else if (e->ts.u.cl->backend_decl)
tmp = e->ts.u.cl->backend_decl;
/* If both of the above approaches fail, then try to generate an
expression from the input, which is only feasible currently, when the
expression can be evaluated to a constant one. */
else
{
/* Try to simplify the expression. */
gfc_simplify_expr (e, 0);
if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
{
/* Amazingly all data is present to compute the length of a
constant string, but the expression is not yet there. */
e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
gfc_charlen_int_kind,
&e->where);
mpz_set_ui (e->ts.u.cl->length->value.integer,
e->value.character.length);
gfc_conv_const_charlen (e->ts.u.cl);
e->ts.u.cl->resolved = 1;
tmp = e->ts.u.cl->backend_decl;
}
else
{
gfc_error ("Cannot compute the length of the char array "
"at %L.", &e->where);
}
}
}
else
tmp = integer_zero_node;
gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
}
else if (class_ts.type == BT_CLASS
&& class_ts.u.derived->components
&& class_ts.u.derived->components->ts.u
.derived->attr.unlimited_polymorphic)
{
ctree = gfc_class_len_get (var);
gfc_add_modify (&parmse->pre, ctree,
fold_convert (TREE_TYPE (ctree),
integer_zero_node));
}
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
/* Takes a scalarized class array expression and returns the
address of a temporary scalar class object of the 'declared'
type.
OOP-TODO: This could be improved by adding code that branched on
the dynamic type being the same as the declared type. In this case
the original class expression can be passed directly.
optional_alloc_ptr is false when the dummy is neither allocatable
nor a pointer; that's relevant for the optional handling.
Set copyback to true if class container's _data and _vtab pointers
might get modified. */
void
gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
bool elemental, bool copyback, bool optional,
bool optional_alloc_ptr)
{
tree ctree;
tree var;
tree tmp;
tree vptr;
tree cond = NULL_TREE;
tree slen = NULL_TREE;
gfc_ref *ref;
gfc_ref *class_ref;
stmtblock_t block;
bool full_array = false;
gfc_init_block (&block);
class_ref = NULL;
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS)
class_ref = ref;
if (ref->next == NULL)
break;
}
if ((ref == NULL || class_ref == ref)
&& !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
&& (!class_ts.u.derived->components->as
|| class_ts.u.derived->components->as->rank != -1))
return;
/* Test for FULL_ARRAY. */
if (e->rank == 0 && gfc_expr_attr (e).codimension
&& gfc_expr_attr (e).dimension)
full_array = true;
else
gfc_is_class_array_ref (e, &full_array);
/* The derived type needs to be converted to a temporary
CLASS object. */
tmp = gfc_typenode_for_spec (&class_ts);
var = gfc_create_var (tmp, "class");
/* Set the data. */
ctree = gfc_class_data_get (var);
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
{
tree type = get_scalar_to_descriptor_type (parmse->expr,
gfc_expr_attr (e));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
tmp = gfc_class_data_get (parmse->expr);
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
gfc_conv_descriptor_data_set (&block, ctree, tmp);
}
else
class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
{
if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&block, ctree, parmse->expr);
}
/* Return the data component, except in the case of scalarized array
references, where nullification of the cannot occur and so there
is no need. */
if (!elemental && full_array && copyback)
{
if (class_ts.u.derived->components->as
&& e->rank != class_ts.u.derived->components->as->rank)
{
if (e->rank == 0)
gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
gfc_conv_descriptor_data_get (ctree));
else
class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
}
else
gfc_add_modify (&parmse->post, parmse->expr, ctree);
}
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
/* The vptr is the second field of the actual argument.
First we have to find the corresponding class reference. */
tmp = NULL_TREE;
if (gfc_is_class_array_function (e)
&& parmse->class_vptr != NULL_TREE)
tmp = parmse->class_vptr;
else if (class_ref == NULL
&& 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 = build_zero_cst (size_type_node);
}
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, e);
class_ref->next = ref;
tmp = tmpse.expr;
slen = tmpse.string_length;
}
gcc_assert (tmp != NULL_TREE);
/* Dereference if needs be. */
if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
vptr = gfc_class_vptr_get (tmp);
else
vptr = tmp;
gfc_add_modify (&block, ctree,
fold_convert (TREE_TYPE (ctree), vptr));
/* Return the vptr 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, vptr,
fold_convert (TREE_TYPE (vptr), ctree));
/* For unlimited polymorphic objects also set the _len component. */
if (class_ts.type == BT_CLASS
&& class_ts.u.derived->components
&& class_ts.u.derived->components->ts.u
.derived->attr.unlimited_polymorphic)
{
ctree = gfc_class_len_get (var);
if (UNLIMITED_POLY (e))
tmp = gfc_class_len_get (tmp);
else if (e->ts.type == BT_CHARACTER)
{
gcc_assert (slen != NULL_TREE);
tmp = slen;
}
else
tmp = build_zero_cst (size_type_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
&& (UNLIMITED_POLY (e) || VAR_P (tmp)))
gfc_add_modify (&parmse->post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}
if (optional)
{
tree tmp2;
cond = gfc_conv_expr_present (e->symtree->n.sym);
/* parmse->pre may contain some preparatory instructions for the
temporary array descriptor. Those may only be executed when the
optional argument is set, therefore add parmse->pre's instructions
to block, which is later guarded by an if (optional_arg_given). */
gfc_add_block_to_block (&parmse->pre, &block);
block.head = parmse->pre.head;
parmse->pre.head = NULL_TREE;
tmp = gfc_finish_block (&block);
if (optional_alloc_ptr)
tmp2 = build_empty_stmt (input_location);
else
{
gfc_init_block (&block);
tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
null_pointer_node));
tmp2 = gfc_finish_block (&block);
}
tmp = build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp, tmp2);
gfc_add_expr_to_block (&parmse->pre, tmp);
}
else
gfc_add_block_to_block (&parmse->pre, &block);
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
if (optional && optional_alloc_ptr)
parmse->expr = build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse->expr),
cond, parmse->expr,
fold_convert (TREE_TYPE (parmse->expr),
null_pointer_node));
}
/* Given a class array declaration and an index, returns the address
of the referenced element. */
static tree
gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
bool unlimited)
{
tree data, size, tmp, ctmp, offset, ptr;
data = data_comp != NULL_TREE ? data_comp :
gfc_class_data_get (class_decl);
size = gfc_class_vtab_size_get (class_decl);
if (unlimited)
{
tmp = fold_convert (gfc_array_index_type,
gfc_class_len_get (class_decl));
ctmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, tmp,
build_zero_cst (TREE_TYPE (tmp)));
size = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, tmp, ctmp, size);
}
offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
data = gfc_conv_descriptor_data_get (data);
ptr = fold_convert (pvoid_type_node, data);
ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
return fold_convert (TREE_TYPE (data), ptr);
}
/* Copies one class expression to another, assuming that if either
'to' or 'from' are arrays they are packed. Should 'from' be
NULL_TREE, the initialization expression for 'to' is used, assuming
that the _vptr is set. */
tree
gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
{
tree fcn;
tree fcn_type;
tree from_data;
tree from_len;
tree to_data;
tree to_len;
tree to_ref;
tree from_ref;
vec<tree, va_gc> *args;
tree tmp;
tree stdcopy;
tree extcopy;
tree index;
bool is_from_desc = false, is_to_class = false;
args = NULL;
/* To prevent warnings on uninitialized variables. */
from_len = to_len = NULL_TREE;
if (from != NULL_TREE)
fcn = gfc_class_vtab_copy_get (from);
else
fcn = gfc_class_vtab_copy_get (to);
fcn_type = TREE_TYPE (TREE_TYPE (fcn));
if (from != NULL_TREE)
{
is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
if (is_from_desc)
{
from_data = from;
from = GFC_DECL_SAVED_DESCRIPTOR (from);
}
else
{
/* 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));
}
}
else
from_data = gfc_class_vtab_def_init_get (to);
if (unlimited)
{
if (from != NULL_TREE && unlimited)
from_len = gfc_class_len_or_zero_get (from);
else
from_len = build_zero_cst (size_type_node);
}
if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
{
is_to_class = true;
to_data = gfc_class_data_get (to);
if (unlimited)
to_len = gfc_class_len_get (to);
}
else
/* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
to_data = to;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
{
stmtblock_t loopbody;
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,
gfc_array_index_type, nelems,
gfc_index_one_node);
nelems = gfc_evaluate_now (tmp, &body);
index = gfc_create_var (gfc_array_index_type, "S");
if (is_from_desc)
{
from_ref = gfc_get_class_array_ref (index, from, from_data,
unlimited);
vec_safe_push (args, from_ref);
}
else
vec_safe_push (args, from_data);
if (is_to_class)
to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
else
{
tmp = gfc_conv_array_data (to);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
to_ref = gfc_build_addr_expr (NULL_TREE,
gfc_build_array_ref (tmp, index, to));
}
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,
logical_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. */
gfc_init_block (&loopbody);
gfc_add_expr_to_block (&loopbody, tmp);
/* Build the loop and return. */
gfc_init_loopinfo (&loop);
loop.dimen = 1;
loop.from[0] = gfc_index_zero_node;
loop.loopvar[0] = index;
loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &loopbody);
gfc_init_block (&ifbody);
gfc_add_block_to_block (&ifbody, &loop.pre);
stdcopy = gfc_finish_block (&ifbody);
/* In initialization mode from_len is a constant zero. */
if (unlimited && !integer_zerop (from_len))
{
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
tmp = build_call_vec (fcn_type, fcn, args);
/* Build the body of the loop. */
gfc_init_block (&loopbody);
gfc_add_expr_to_block (&loopbody, tmp);
/* Build the loop and return. */
gfc_init_loopinfo (&loop);
loop.dimen = 1;
loop.from[0] = gfc_index_zero_node;
loop.loopvar[0] = index;
loop.to[0] = nelems;
gfc_trans_scalarizing_loops (&loop, &loopbody);
gfc_init_block (&ifbody);
gfc_add_block_to_block (&ifbody, &loop.pre);
extcopy = gfc_finish_block (&ifbody);
tmp = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len)));
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy);
gfc_add_expr_to_block (&body, tmp);
tmp = gfc_finish_block (&body);
}
else
{
gfc_add_expr_to_block (&body, stdcopy);
tmp = gfc_finish_block (&body);
}
gfc_cleanup_loop (&loop);
}
else
{
gcc_assert (!is_from_desc);
vec_safe_push (args, from_data);
vec_safe_push (args, to_data);
stdcopy = build_call_vec (fcn_type, fcn, args);
/* In initialization mode from_len is a constant zero. */
if (unlimited && !integer_zerop (from_len))
{
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
tmp = fold_build2_loc (input_location, GT_EXPR,
logical_type_node, from_len,
build_zero_cst (TREE_TYPE (from_len)));
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, tmp, extcopy, stdcopy);
}
else
tmp = stdcopy;
}
/* Only copy _def_init to to_data, when it is not a NULL-pointer. */
if (from == NULL_TREE)
{
tree cond;
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
from_data, null_pointer_node);
tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, cond,
tmp, build_empty_stmt (input_location));
}
return tmp;
}
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_code *ppc_code;
tree res;
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (lhs);
ppc = gfc_copy_expr (obj);
gfc_add_vptr_component (ppc);
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code (EXEC_CALL);
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.cc, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
gfc_free_statements (ppc_code);
if (UNLIMITED_POLY(obj))
{
/* Check if rhs is non-NULL. */
gfc_se src;
gfc_init_se (&src, NULL);
gfc_conv_expr (&src, rhs);
src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
src.expr, fold_convert (TREE_TYPE (src.expr),
null_pointer_node));
res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
build_empty_stmt (input_location));
}
return res;
}
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
A MEMCPY is needed to copy the full data from the default initializer
of the dynamic type. */
tree
gfc_trans_class_init_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_start_block (&block);
lhs = gfc_copy_expr (code->expr1);
rhs = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (rhs);
/* Make sure that the component backend_decls have been built, which
will not have happened if the derived types concerned have not
been referenced. */
gfc_get_derived_type (rhs->ts.u.derived);
gfc_add_def_init_component (rhs);
/* The _def_init is always scalar. */
rhs->rank = 0;
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
{
gfc_array_spec *tmparr = gfc_get_array_spec ();
*tmparr = *CLASS_DATA (code->expr1)->as;
/* Adding the array ref to the class expression results in correct
indexing to the dynamic type. */
gfc_add_full_array_ref (lhs, tmparr);
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
}
else
{
/* Scalar initialization needs the _data component. */
gfc_add_data_component (lhs);
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&memsz, NULL);
gfc_conv_expr (&dst, lhs);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
if (UNLIMITED_POLY(code->expr1))
{
/* Check if _def_init is non-NULL. */
tree cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, src.expr,
fold_convert (TREE_TYPE (src.expr),
null_pointer_node));
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
tmp, build_empty_stmt (input_location));
}
}
if (code->expr1->symtree->n.sym->attr.dummy
&& (code->expr1->symtree->n.sym->attr.optional
|| code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
{
tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
present, tmp,
build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Class valued elemental function calls or class array elements arriving
in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
is used to ensure that the rhs dynamic type is assigned to the lhs. */
static bool
trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
{
tree fcn;
tree rse_expr;
tree class_data;
tree tmp;
tree zero;
tree cond;
tree final_cond;
stmtblock_t inner_block;
bool is_descriptor;
bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
bool not_lhs_array_type;
/* Temporaries arising from dependencies in assignment get cast as a
character type of the dynamic size of the rhs. Use the vptr copy
for this case. */
tmp = TREE_TYPE (lse->expr);
not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
/* Use ordinary assignment if the rhs is not a call expression or
the lhs is not a class entity or an array(ie. character) type. */
if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
&& not_lhs_array_type)
return false;
/* Ordinary assignment can be used if both sides are class expressions
since the dynamic type is preserved by copying the vptr. This
should only occur, where temporaries are involved. */
if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
&& GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
return false;
/* Fix the class expression and the class data of the rhs. */
if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
|| not_call_expr)
{
tmp = gfc_get_class_from_expr (rse->expr);
if (tmp == NULL_TREE)
return false;
rse_expr = gfc_evaluate_now (tmp, block);
}
else
rse_expr = gfc_evaluate_now (rse->expr, block);
class_data = gfc_class_data_get (rse_expr);
/* Check that the rhs data is not null. */
is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
if (is_descriptor)
class_data = gfc_conv_descriptor_data_get (class_data);
class_data = gfc_evaluate_now (class_data, block);
zero = build_int_cst (TREE_TYPE (class_data), 0);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
class_data, zero);
/* Copy the rhs to the lhs. */
fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
fcn = build_fold_indirect_ref_loc (input_location, fcn);
tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
tmp = is_descriptor ? tmp : class_data;
tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
gfc_build_addr_expr (NULL, lse->expr));
gfc_add_expr_to_block (block, tmp);
/* Only elemental function results need to be finalised and freed. */
if (not_call_expr)
return true;
/* Finalize the class data if needed. */
gfc_init_block (&inner_block);
fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
zero = build_int_cst (TREE_TYPE (fcn), 0);
final_cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, fcn, zero);
fcn = build_fold_indirect_ref_loc (input_location, fcn);
tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
tmp = build3_v (COND_EXPR, final_cond,
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&inner_block, tmp);
/* Free the class data. */
tmp = gfc_call_free (class_data);
tmp = build3_v (COND_EXPR, cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&inner_block, tmp);
/* Finish the inner block and subject it to the condition on the
class data being non-zero. */
tmp = gfc_finish_block (&inner_block);
tmp = build3_v (COND_EXPR, cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
return true;
}
/* End of prototype trans-class.c */
static void
realloc_lhs_warning (bt type, bool array, locus *where)
{
if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
gfc_warning (OPT_Wrealloc_lhs,
"Code for reallocating the allocatable array at %L will "
"be added", where);
else if (warn_realloc_lhs_all)
gfc_warning (OPT_Wrealloc_lhs_all,
"Code for reallocating the allocatable variable at %L "
"will be added", where);
}
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
/* Copy the scalarization loop variables. */
static void
gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
{
dest->ss = src->ss;
dest->loop = src->loop;
}
/* Initialize a simple expression holder.
Care must be taken when multiple se are created with the same parent.
The child se must be kept in sync. The easiest way is to delay creation
of a child se until after the previous se has been translated. */
void
gfc_init_se (gfc_se * se, gfc_se * parent)
{
memset (se, 0, sizeof (gfc_se));
gfc_init_block (&se->pre);
gfc_init_block (&se->post);
se->parent = parent;
if (parent)
gfc_copy_se_loopvars (se, parent);
}
/* Advances to the next SS in the chain. Use this rather than setting
se->ss = se->ss->next because all the parents needs to be kept in sync.
See gfc_init_se. */
void
gfc_advance_se_ss_chain (gfc_se * se)
{
gfc_se *p;
gfc_ss *ss;
gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
p = se;
/* Walk down the parent chain. */
while (p != NULL)
{
/* Simple consistency check. */
gcc_assert (p->parent == NULL || p->parent->ss == p->ss
|| p->parent->ss->nested_ss == p->ss);
/* If we were in a nested loop, the next scalarized expression can be
on the parent ss' next pointer. Thus we should not take the next
pointer blindly, but rather go up one nest level as long as next
is the end of chain. */
ss = p->ss;
while (ss->next == gfc_ss_terminator && ss->parent != NULL)
ss = ss->parent;
p->ss = ss->next;
p = p->parent;
}
}
/* Ensures the result of the expression as either a temporary variable
or a constant so that it can be used repeatedly. */
void
gfc_make_safe_expr (gfc_se * se)
{
tree var;
if (CONSTANT_CLASS_P (se->expr))
return;
/* We need a temporary for this result. */
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, var, se->expr);
se->expr = var;
}
/* Return an expression which determines if a dummy parameter is present.
Also used for arguments to procedures with multiple entry points. */
tree
gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
{
tree decl, orig_decl, cond;
gcc_assert (sym->attr.dummy);
orig_decl = decl = gfc_get_symbol_decl (sym);
/* Intrinsic scalars with VALUE attribute which are passed by value
use a hidden argument to denote the present status. */
if (sym->attr.value && sym->ts.type != BT_CHARACTER
&& sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
&& !sym->attr.dimension)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
tree tree_name;
gcc_assert (TREE_CODE (decl) == PARM_DECL);
name[0] = '_';
strcpy (&name[1], sym->name);
tree_name = get_identifier (name);
/* Walk function argument list to find hidden arg. */
cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
if (DECL_NAME (cond) == tree_name
&& DECL_ARTIFICIAL (cond))
break;
gcc_assert (cond);
return cond;
}
/* Assumed-shape arrays use a local variable for the array data;
the actual PARAM_DECL is in a saved decl. As the local variable
is NULL, it can be checked instead, unless use_saved_desc is
requested. */
if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
}
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
fold_convert (TREE_TYPE (decl), null_pointer_node));
/* Fortran 2008 allows to pass null pointers and non-associated pointers
as actual argument to denote absent dummies. For array descriptors,
we thus also need to check the array descriptor. For BT_CLASS, it
can also occur for scalars and F2003 due to type->class wrapping and
class->class wrapping. Note further that BT_CLASS always uses an
array descriptor for arrays, also for explicit-shape/assumed-size.
For assumed-rank arrays, no local variable is generated, hence,
the following also applies with !use_saved_desc. */
if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
&& !sym->attr.allocatable
&& ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
|| (sym->ts.type == BT_CLASS
&& !CLASS_DATA (sym)->attr.allocatable
&& !CLASS_DATA (sym)->attr.class_pointer))
&& ((gfc_option.allow_std & GFC_STD_F2008) != 0
|| sym->ts.type == BT_CLASS))
{
tree tmp;
if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
|| sym->as->type == AS_ASSUMED_RANK
|| sym->attr.codimension))
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
{
tmp = build_fold_indirect_ref_loc (input_location, decl);
if (sym->ts.type == BT_CLASS)
tmp = gfc_class_data_get (tmp);
tmp = gfc_conv_array_data (tmp);
}
else if (sym->ts.type == BT_CLASS)
tmp = gfc_class_data_get (decl);
else
tmp = NULL_TREE;
if (tmp != NULL_TREE)
{
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
logical_type_node, cond, tmp);
}
}
return cond;
}
/* Converts a missing, dummy argument into a null or zero. */
void
gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
{
tree present;
tree tmp;
present = gfc_conv_expr_present (arg->symtree->n.sym);
if (kind > 0)
{
/* Create a temporary and convert it to the correct type. */
tmp = gfc_get_int_type (kind);
tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
se->expr));
/* Test for a NULL value. */
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
present, se->expr,
build_zero_cst (TREE_TYPE (se->expr)));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = tmp;
}
if (ts.type == BT_CHARACTER)
{
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
present, se->string_length, tmp);
tmp = gfc_evaluate_now (tmp, &se->pre);
se->string_length = tmp;
}
return;
}
/* Get the character length of an expression, looking through gfc_refs
if necessary. */
tree
gfc_get_expr_charlen (gfc_expr *e)
{
gfc_ref *r;
tree length;
gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
length = NULL; /* To silence compiler warning. */
if (is_subref_array (e) && e->ts.u.cl->length)
{
gfc_se tmpse;
gfc_init_se (&tmpse, NULL);
gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
e->ts.u.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. */
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
length = e->symtree->n.sym->ts.u.cl->backend_decl;
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
{
switch (r->type)
{
case REF_COMPONENT:
if (r->u.c.component->ts.type == BT_CHARACTER)
length = r->u.c.component->ts.u.cl->backend_decl;
break;
case REF_ARRAY:
/* Do nothing. */
break;
case REF_SUBSTRING:
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
length = se.expr;
gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
length = fold_build2_loc (input_location, MINUS_EXPR,
gfc_charlen_type_node,
se.expr, length);
length = fold_build2_loc (input_location, PLUS_EXPR,
gfc_charlen_type_node, length,
gfc_index_one_node);
break;
default:
gcc_unreachable ();
break;
}
}
gcc_assert (length != NULL);
return length;
}
/* Return for an expression the backend decl of the coarray. */
tree
gfc_get_tree_for_caf_expr (gfc_expr *expr)
{
tree caf_decl;
bool found = false;
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)
{
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);
}
/* 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)
{
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;
/* The following code assumes that the coarray is a component reachable via
only scalar components/variables; the Fortran standard guarantees this. */
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
{
gfc_component *comp = ref->u.c.component;
if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
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);
if (CLASS_DATA (comp)->attr.codimension)
{
found = true;
break;
}
}
if (comp->attr.codimension)
{
found = true;
break;
}
}
gcc_assert (found && caf_decl);
return caf_decl;
}
/* Obtain the Coarray token - and optionally also the offset. */
void
gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
tree se_expr, gfc_expr *expr)
{
tree tmp;
/* Coarray token. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
{
gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
== GFC_ARRAY_ALLOCATABLE
|| expr->symtree->n.sym->attr.select_type_temporary);
*token = gfc_conv_descriptor_token (caf_decl);
}
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
*token = GFC_DECL_TOKEN (caf_decl);
else
{
gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
&& GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
*token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
}
if (offset == NULL)
return;
/* Offset between the coarray base address and the address wanted. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
&& (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
|| GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
*offset = build_int_cst (gfc_array_index_type, 0);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
*offset = GFC_DECL_CAF_OFFSET (caf_decl);
else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
*offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
else
*offset = build_int_cst (gfc_array_index_type, 0);
if (POINTER_TYPE_P (TREE_TYPE (se_expr))
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
{
tmp = build_fold_indirect_ref_loc (input_location, se_expr);
tmp = gfc_conv_descriptor_data_get (tmp);
}
else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
tmp = gfc_conv_descriptor_data_get (se_expr);
else
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
tmp = se_expr;
}
*offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
*offset, fold_convert (gfc_array_index_type, tmp));
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
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
tmp = caf_decl;
}
*offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
fold_convert (gfc_array_index_type, *offset),
fold_convert (gfc_array_index_type, tmp));
}
/* Convert the coindex of a coarray into an image index; the result is
image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
+ (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
tree
gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
{
gfc_ref *ref;
tree lbound, ubound, extent, tmp, img_idx;
gfc_se se;
int i;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
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 = build_zero_cst (gfc_array_index_type);
extent = build_one_cst (gfc_array_index_type);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (lbound), se.expr, lbound);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
extent, tmp);
img_idx = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (tmp), img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
}
else
for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (lbound), se.expr, lbound);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
extent, tmp);
img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (ubound), ubound, lbound);
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
tmp, build_one_cst (TREE_TYPE (tmp)));
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
}
img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
img_idx, build_one_cst (TREE_TYPE (img_idx)));
return fold_convert (integer_type_node, img_idx);
}
/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
static void
flatten_array_ctors_without_strlen (gfc_expr* e)
{
gfc_actual_arglist* arg;
gfc_constructor* c;
if (!e)
return;
switch (e->expr_type)
{
case EXPR_OP:
flatten_array_ctors_without_strlen (e->value.op.op1);
flatten_array_ctors_without_strlen (e->value.op.op2);
break;
case EXPR_COMPCALL:
/* TODO: Implement as with EXPR_FUNCTION when needed. */
gcc_unreachable ();
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
flatten_array_ctors_without_strlen (arg->expr);
break;
case EXPR_ARRAY:
/* We've found what we're looking for. */
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
gfc_constructor *c;
gfc_expr* new_expr;
gcc_assert (e->value.constructor);
c = gfc_constructor_first (e->value.constructor);
new_expr = c->expr;
c->expr = NULL;
flatten_array_ctors_without_strlen (new_expr);
gfc_replace_expr (e, new_expr);
break;
}
/* 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))
flatten_array_ctors_without_strlen (c->expr);
break;
default:
break;
}
}
/* Generate code to initialize a string length variable. Returns the
value. For array constructors, cl->length might be NULL and in this case,
the first element of the constructor is needed. expr is the original
expression so we can access it but can be NULL if this is not needed. */
void
gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
{
gfc_se se;
gfc_init_se (&se, NULL);
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
"flatten" array constructors by taking their first element; all elements
should be the same length or a cl->length should be present. */
if (!cl->length)
{
gfc_expr* expr_flat;
if (!expr)
return;
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
gfc_conv_expr (&se, expr_flat);
gfc_add_block_to_block (pblock, &se.pre);
cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
gfc_free_expr (expr_flat);
return;
}
/* Convert cl->length. */
gcc_assert (cl->length);
gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
se.expr, build_zero_cst (TREE_TYPE (se.expr)));
gfc_add_block_to_block (pblock, &se.pre);
if (cl->backend_decl && VAR_P (cl->backend_decl))
gfc_add_modify (pblock, cl->backend_decl, se.expr);
else
cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
}
static void
gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
const char *name, locus *where)
{
tree tmp;
tree type;
tree fault;
gfc_se start;
gfc_se end;
char *msg;
mpz_t length;
type = gfc_get_character_type (kind, ref->u.ss.length);
type = build_pointer_type (type);
gfc_init_se (&start, se);
gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &start.pre);
if (integer_onep (start.expr))
gfc_conv_string_parameter (se);
else
{
tmp = start.expr;
STRIP_NOPS (tmp);
/* Avoid multiple evaluation of substring start. */
if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
|| TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
&& TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
tmp = build_fold_indirect_ref_loc (input_location,
se->expr);
/* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
{
tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
se->expr = gfc_build_addr_expr (type, tmp);
}
}
/* Length = end + 1 - start. */
gfc_init_se (&end, se);
if (ref->u.ss.end == NULL)
end.expr = se->string_length;
else
{
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
tmp = end.expr;
STRIP_NOPS (tmp);
if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
end.expr = gfc_evaluate_now (end.expr, &se->pre);
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& (ref->u.ss.start->symtree
&& !ref->u.ss.start->symtree->n.sym->attr.implied_index))
{
tree nonempty = fold_build2_loc (input_location, LE_EXPR,
logical_type_node, start.expr,
end.expr);
/* Check lower bound. */
fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
start.expr,
build_one_cst (TREE_TYPE (start.expr)));
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
logical_type_node, nonempty, fault);
if (name)
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) "
"is less than one");
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
start.expr));
free (msg);
/* Check upper bound. */
fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
end.expr, se->string_length);
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
logical_type_node, nonempty, fault);
if (name)
msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
"exceeds string length (%%ld)", name);
else
msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
"exceeds string length (%%ld)");
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node,
se->string_length));
free (msg);
}
/* Try to calculate the length from the start and end expressions. */
if (ref->u.ss.end
&& gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
{
HOST_WIDE_INT i_len;
i_len = gfc_mpz_get_hwi (length) + 1;
if (i_len < 0)
i_len = 0;
tmp = build_int_cst (gfc_charlen_type_node, i_len);
mpz_clear (length); /* Was initialized by gfc_dep_difference. */
}
else
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, end.expr),
fold_convert (gfc_charlen_type_node, start.expr));
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
build_int_cst (gfc_charlen_type_node, 1), tmp);
tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
tmp, build_int_cst (gfc_charlen_type_node, 0));
}
se->string_length = tmp;
}
/* Convert a derived type component reference. */
void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
tree tmp;
tree decl;
tree field;
tree context;
c = ref->u.c.component;
if (c->backend_decl == NULL_TREE
&& ref->u.c.sym != NULL)
gfc_get_derived_type (ref->u.c.sym);
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.
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 (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))
for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
if (TREE_CODE (f2) == FIELD_DECL
&& DECL_NAME (f2) == DECL_NAME (field))
break;
gcc_assert (f2);
c->norestrict_decl = f2;
field = f2;
}
if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
&& strcmp ("_data", c->name) == 0)
{
/* Found a ref to the _data component. Store the associated ref to
the vptr in se->class_vptr. */
se->class_vptr = gfc_class_vptr_get (decl);
}
else
se->class_vptr = NULL_TREE;
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);
se->expr = tmp;
/* Allocatable deferred char arrays are to be handled by the gfc_deferred_
strlen () conditional below. */
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
&& !c->ts.deferred
&& !c->attr.pdt_string)
{
tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
gcc_assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
}
if (gfc_deferred_strlen (c, &field))
{
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field),
decl, field, NULL_TREE);
se->string_length = tmp;
}
if (((c->attr.pointer || c->attr.allocatable)
&& (!c->attr.dimension && !c->attr.codimension)
&& c->ts.type != BT_CHARACTER)
|| c->attr.proc_pointer)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
/* This function deals with component references to components of the
parent type for derived type extensions. */
void
conv_parent_component_references (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
gfc_component *cmp;
gfc_symbol *dt;
gfc_ref parent;
dt = ref->u.c.sym;
c = ref->u.c.component;
/* Return if the component is in this type, i.e. not in the parent type. */
for (cmp = dt->components; cmp; cmp = cmp->next)
if (c == cmp)
return;
/* Build a gfc_ref to recursively call gfc_conv_component_ref. */
parent.type = REF_COMPONENT;
parent.next = NULL;
parent.u.c.sym = dt;
parent.u.c.component = dt->components;
if (dt->backend_decl == NULL)
gfc_get_derived_type (dt);
/* Build the reference and call self. */
gfc_conv_component_ref (se, &parent);
parent.u.c.sym = dt->components->ts.u.derived;
parent.u.c.component = c;
conv_parent_component_references (se, &parent);
}
static void
conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
{
tree res = se->expr;
switch (ref->u.i)
{
case INQUIRY_RE:
res = fold_build1_loc (input_location, REALPART_EXPR,
TREE_TYPE (TREE_TYPE (res)), res);
break;
case INQUIRY_IM:
res = fold_build1_loc (input_location, IMAGPART_EXPR,
TREE_TYPE (TREE_TYPE (res)), res);
break;
case INQUIRY_KIND:
res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
ts->kind);
break;
case INQUIRY_LEN:
res = fold_convert (gfc_typenode_for_spec (&expr->ts),
se->string_length);
break;
default:
gcc_unreachable ();
}
se->expr = res;
}
/* Dereference VAR where needed if it is a pointer, reference, etc.
according to Fortran semantics. */
tree
gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
bool is_classarray)
{
if (!POINTER_TYPE_P (TREE_TYPE (var)))
return var;
if (is_CFI_desc (sym, NULL))
return build_fold_indirect_ref_loc (input_location, var);
/* Characters are entirely different from other types, they are treated
separately. */
if (sym->ts.type == BT_CHARACTER)
{
/* Dereference character pointer dummy arguments
or results. */
if ((sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result))
var = build_fold_indirect_ref_loc (input_location, var);
}
else if (!sym->attr.value)
{
/* Dereference temporaries for class array dummy arguments. */
if (sym->attr.dummy && is_classarray
&& GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
{
if (!descriptor_only_p)
var = GFC_DECL_SAVED_DESCRIPTOR (var);
var = build_fold_indirect_ref_loc (input_location, var);
}
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension
&& !(sym->attr.codimension && sym->attr.allocatable)
&& (sym->ts.type != BT_CLASS
|| (!CLASS_DATA (sym)->attr.dimension
&& !(CLASS_DATA (sym)->attr.codimension
&& CLASS_DATA (sym)->attr.allocatable))))
var = build_fold_indirect_ref_loc (input_location, var);
/* Dereference scalar hidden result. */
if (flag_f2c && sym->ts.type == BT_COMPLEX
&& (sym->attr.function || sym->attr.result)
&& !sym->attr.dimension && !sym->attr.pointer
&& !sym->attr.always_explicit)
var = build_fold_indirect_ref_loc (input_location, var);
/* Dereference non-character, non-class pointer variables.
These must be dummies, results, or scalars. */
if (!is_classarray
&& (sym->attr.pointer || sym->attr.allocatable
|| gfc_is_associate_pointer (sym)
|| (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
|| (!sym->attr.dimension
&& (!sym->attr.codimension || !sym->attr.allocatable))))
var = build_fold_indirect_ref_loc (input_location, var);
/* Now treat the class array pointer variables accordingly. */
else if (sym->ts.type == BT_CLASS
&& sym->attr.dummy
&& (CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.codimension)
&& ((CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (sym)->attr.allocatable
|| CLASS_DATA (sym)->attr.class_pointer))
var = build_fold_indirect_ref_loc (input_location, var);
/* And the case where a non-dummy, non-result, non-function,
non-allocable and non-pointer classarray is present. This case was
previously covered by the first if, but with introducing the
condition !is_classarray there, that case has to be covered
explicitly. */
else if (sym->ts.type == BT_CLASS
&& !sym->attr.dummy
&& !sym->attr.function
&& !sym->attr.result
&& (CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.codimension)
&& (sym->assoc
|| !CLASS_DATA (sym)->attr.allocatable)
&& !CLASS_DATA (sym)->attr.class_pointer)
var = build_fold_indirect_ref_loc (input_location, var);
}
return var;
}
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
gfc_ss *ss;
gfc_ref *ref;
gfc_symbol *sym;
tree parent_decl = NULL_TREE;
int parent_flag;
bool return_value;
bool alternate_entry;
bool entry_master;
bool is_classarray;
bool first_time = true;
sym = expr->symtree->n.sym;
is_classarray = IS_CLASS_ARRAY (sym);
ss = se->ss;
if (ss != NULL)
{
gfc_ss_info *ss_info = ss->info;
/* Check that something hasn't gone horribly wrong. */
gcc_assert (ss != gfc_ss_terminator);
gcc_assert (ss_info->expr == expr);
/* A scalarized term. We already know the descriptor. */
se->expr = ss_info->data.array.descriptor;
se->string_length = ss_info->string_length;
ref = ss_info->data.array.ref;
if (ref)
gcc_assert (ref->type == REF_ARRAY
&& ref->u.ar.type != AR_ELEMENT);
else
gfc_conv_tmp_array_ref (se);
}
else
{
tree se_expr = NULL_TREE;
se->expr = gfc_get_symbol_decl (sym);
/* Deal with references to a parent results or entries by storing
the current_function_decl and moving to the parent_decl. */
return_value = sym->attr.function && sym->result == sym;
alternate_entry = sym->attr.function && sym->attr.entry
&& sym->result == sym;
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
if (current_function_decl)
parent_decl = DECL_CONTEXT (current_function_decl);
if ((se->expr == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
&& parent_decl
&& sym->ns->proc_name->backend_decl == parent_decl
&& (alternate_entry || entry_master)))
parent_flag = 1;
else
parent_flag = 0;
/* Special case for assigning the return value of a function.
Self recursive functions must have an explicit return value. */
if (return_value && (se->expr == current_function_decl || parent_flag))
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
/* Similarly for alternate entry points. */
else if (alternate_entry
&& (sym->ns->proc_name->backend_decl == current_function_decl
|| parent_flag))
{
gfc_entry_list *el = NULL;