mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-03 00:29:47 +00:00
12140 lines
372 KiB
C++
12140 lines
372 KiB
C++
/* 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;
|
|
|
|
for (el = sym->ns->entries; el; el = el->next)
|
|
if (sym == el->sym)
|
|
{
|
|
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
|
|
break;
|
|
}
|
|
}
|
|
|
|
else if (entry_master
|
|
&& (sym->ns->proc_name->backend_decl == current_function_decl
|
|
|| parent_flag))
|
|
se_expr = gfc_get_fake_result_decl (sym, parent_flag);
|
|
|
|
if (se_expr)
|
|
se->expr = se_expr;
|
|
|
|
/* 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)
|
|
{
|
|
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
|
}
|
|
return;
|
|
}
|
|
|
|
/* Dereference the expression, where needed. */
|
|
se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
|
|
is_classarray);
|
|
|
|
ref = expr->ref;
|
|
}
|
|
|
|
/* For character variables, also get the length. */
|
|
if (sym->ts.type == BT_CHARACTER)
|
|
{
|
|
/* If the character length of an entry isn't set, get the length from
|
|
the master function instead. */
|
|
if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
|
|
se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
|
|
else
|
|
se->string_length = sym->ts.u.cl->backend_decl;
|
|
gcc_assert (se->string_length);
|
|
}
|
|
|
|
gfc_typespec *ts = &sym->ts;
|
|
while (ref)
|
|
{
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
/* Return the descriptor if that's what we want and this is an array
|
|
section reference. */
|
|
if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
|
|
return;
|
|
/* TODO: Pointers to single elements of array sections, eg elemental subs. */
|
|
/* Return the descriptor for array pointers and allocations. */
|
|
if (se->want_pointer
|
|
&& ref->next == NULL && (se->descriptor_only))
|
|
return;
|
|
|
|
gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
|
|
/* Return a pointer to an element. */
|
|
break;
|
|
|
|
case REF_COMPONENT:
|
|
ts = &ref->u.c.component->ts;
|
|
if (first_time && is_classarray && sym->attr.dummy
|
|
&& se->descriptor_only
|
|
&& !CLASS_DATA (sym)->attr.allocatable
|
|
&& !CLASS_DATA (sym)->attr.class_pointer
|
|
&& CLASS_DATA (sym)->as
|
|
&& CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
|
|
&& strcmp ("_data", ref->u.c.component->name) == 0)
|
|
/* Skip the first ref of a _data component, because for class
|
|
arrays that one is already done by introducing a temporary
|
|
array descriptor. */
|
|
break;
|
|
|
|
if (ref->u.c.sym->attr.extension)
|
|
conv_parent_component_references (se, ref);
|
|
|
|
gfc_conv_component_ref (se, ref);
|
|
if (!ref->next && ref->u.c.sym->attr.codimension
|
|
&& se->want_pointer && se->descriptor_only)
|
|
return;
|
|
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
gfc_conv_substring (se, ref, expr->ts.kind,
|
|
expr->symtree->name, &expr->where);
|
|
break;
|
|
|
|
case REF_INQUIRY:
|
|
conv_inquiry (se, ref, expr, ts);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
first_time = false;
|
|
ref = ref->next;
|
|
}
|
|
/* Pointer assignment, allocation or pass by reference. Arrays are handled
|
|
separately. */
|
|
if (se->want_pointer)
|
|
{
|
|
if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
|
|
gfc_conv_string_parameter (se);
|
|
else
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
|
}
|
|
}
|
|
|
|
|
|
/* Unary ops are easy... Or they would be if ! was a valid op. */
|
|
|
|
static void
|
|
gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_se operand;
|
|
tree type;
|
|
|
|
gcc_assert (expr->ts.type != BT_CHARACTER);
|
|
/* Initialize the operand. */
|
|
gfc_init_se (&operand, se);
|
|
gfc_conv_expr_val (&operand, expr->value.op.op1);
|
|
gfc_add_block_to_block (&se->pre, &operand.pre);
|
|
|
|
type = gfc_typenode_for_spec (&expr->ts);
|
|
|
|
/* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
|
|
We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
|
|
All other unary operators have an equivalent GIMPLE unary operator. */
|
|
if (code == TRUTH_NOT_EXPR)
|
|
se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
|
|
build_int_cst (type, 0));
|
|
else
|
|
se->expr = fold_build1_loc (input_location, code, type, operand.expr);
|
|
|
|
}
|
|
|
|
/* Expand power operator to optimal multiplications when a value is raised
|
|
to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
|
|
Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
|
|
Programming", 3rd Edition, 1998. */
|
|
|
|
/* This code is mostly duplicated from expand_powi in the backend.
|
|
We establish the "optimal power tree" lookup table with the defined size.
|
|
The items in the table are the exponents used to calculate the index
|
|
exponents. Any integer n less than the value can get an "addition chain",
|
|
with the first node being one. */
|
|
#define POWI_TABLE_SIZE 256
|
|
|
|
/* The table is from builtins.cc. */
|
|
static const unsigned char powi_table[POWI_TABLE_SIZE] =
|
|
{
|
|
0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
|
|
4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
|
|
8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
|
|
12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
|
|
16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
|
|
20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
|
|
24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
|
|
28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
|
|
32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
|
|
36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
|
|
40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
|
|
44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
|
|
48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
|
|
52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
|
|
56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
|
|
60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
|
|
64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
|
|
68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
|
|
72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
|
|
76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
|
|
80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
|
|
84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
|
|
88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
|
|
92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
|
|
96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
|
|
100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
|
|
104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
|
|
108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
|
|
112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
|
|
116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
|
|
120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
|
|
124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
|
|
};
|
|
|
|
/* If n is larger than lookup table's max index, we use the "window
|
|
method". */
|
|
#define POWI_WINDOW_SIZE 3
|
|
|
|
/* Recursive function to expand the power operator. The temporary
|
|
values are put in tmpvar. The function returns tmpvar[1] ** n. */
|
|
static tree
|
|
gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
|
|
{
|
|
tree op0;
|
|
tree op1;
|
|
tree tmp;
|
|
int digit;
|
|
|
|
if (n < POWI_TABLE_SIZE)
|
|
{
|
|
if (tmpvar[n])
|
|
return tmpvar[n];
|
|
|
|
op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
|
|
op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
|
|
}
|
|
else if (n & 1)
|
|
{
|
|
digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
|
|
op0 = gfc_conv_powi (se, n - digit, tmpvar);
|
|
op1 = gfc_conv_powi (se, digit, tmpvar);
|
|
}
|
|
else
|
|
{
|
|
op0 = gfc_conv_powi (se, n >> 1, tmpvar);
|
|
op1 = op0;
|
|
}
|
|
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
|
|
tmp = gfc_evaluate_now (tmp, &se->pre);
|
|
|
|
if (n < POWI_TABLE_SIZE)
|
|
tmpvar[n] = tmp;
|
|
|
|
return tmp;
|
|
}
|
|
|
|
|
|
/* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
|
|
return 1. Else return 0 and a call to runtime library functions
|
|
will have to be built. */
|
|
static int
|
|
gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
|
|
{
|
|
tree cond;
|
|
tree tmp;
|
|
tree type;
|
|
tree vartmp[POWI_TABLE_SIZE];
|
|
HOST_WIDE_INT m;
|
|
unsigned HOST_WIDE_INT n;
|
|
int sgn;
|
|
wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
|
|
|
|
/* If exponent is too large, we won't expand it anyway, so don't bother
|
|
with large integer values. */
|
|
if (!wi::fits_shwi_p (wrhs))
|
|
return 0;
|
|
|
|
m = wrhs.to_shwi ();
|
|
/* 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);
|
|
|
|
if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
|
|
|| optimize_size) && (m > 2 || m < -1))
|
|
return 0;
|
|
|
|
/* rhs == 0 */
|
|
if (sgn == 0)
|
|
{
|
|
se->expr = gfc_build_const (type, integer_one_node);
|
|
return 1;
|
|
}
|
|
|
|
/* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
|
|
if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
|
|
{
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
|
|
lhs, build_int_cst (TREE_TYPE (lhs), -1));
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
|
|
lhs, build_int_cst (TREE_TYPE (lhs), 1));
|
|
|
|
/* If rhs is even,
|
|
result = (lhs == 1 || lhs == -1) ? 1 : 0. */
|
|
if ((n & 1) == 0)
|
|
{
|
|
tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
|
|
logical_type_node, tmp, cond);
|
|
se->expr = fold_build3_loc (input_location, COND_EXPR, type,
|
|
tmp, build_int_cst (type, 1),
|
|
build_int_cst (type, 0));
|
|
return 1;
|
|
}
|
|
/* If rhs is odd,
|
|
result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
|
|
tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
|
|
build_int_cst (type, -1),
|
|
build_int_cst (type, 0));
|
|
se->expr = fold_build3_loc (input_location, COND_EXPR, type,
|
|
cond, build_int_cst (type, 1), tmp);
|
|
return 1;
|
|
}
|
|
|
|
memset (vartmp, 0, sizeof (vartmp));
|
|
vartmp[1] = lhs;
|
|
if (sgn == -1)
|
|
{
|
|
tmp = gfc_build_const (type, integer_one_node);
|
|
vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
|
|
vartmp[1]);
|
|
}
|
|
|
|
se->expr = gfc_conv_powi (se, n, vartmp);
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
/* Power op (**). Constant integer exponent has special handling. */
|
|
|
|
static void
|
|
gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
tree gfc_int4_type_node;
|
|
int kind;
|
|
int ikind;
|
|
int res_ikind_1, res_ikind_2;
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
tree fndecl = NULL;
|
|
|
|
gfc_init_se (&lse, se);
|
|
gfc_conv_expr_val (&lse, expr->value.op.op1);
|
|
lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
|
|
gfc_add_block_to_block (&se->pre, &lse.pre);
|
|
|
|
gfc_init_se (&rse, se);
|
|
gfc_conv_expr_val (&rse, expr->value.op.op2);
|
|
gfc_add_block_to_block (&se->pre, &rse.pre);
|
|
|
|
if (expr->value.op.op2->ts.type == BT_INTEGER
|
|
&& expr->value.op.op2->expr_type == EXPR_CONSTANT)
|
|
if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
|
|
return;
|
|
|
|
if (INTEGER_CST_P (lse.expr)
|
|
&& TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
|
|
{
|
|
wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
|
|
HOST_WIDE_INT v, w;
|
|
int kind, ikind, bit_size;
|
|
|
|
v = wlhs.to_shwi ();
|
|
w = abs (v);
|
|
|
|
kind = expr->value.op.op1->ts.kind;
|
|
ikind = gfc_validate_kind (BT_INTEGER, kind, false);
|
|
bit_size = gfc_integer_kinds[ikind].bit_size;
|
|
|
|
if (v == 1)
|
|
{
|
|
/* 1**something is always 1. */
|
|
se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
|
|
return;
|
|
}
|
|
else if (v == -1)
|
|
{
|
|
/* (-1)**n is 1 - ((n & 1) << 1) */
|
|
tree type;
|
|
tree tmp;
|
|
|
|
type = TREE_TYPE (lse.expr);
|
|
tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
|
|
rse.expr, build_int_cst (type, 1));
|
|
tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
|
|
tmp, build_int_cst (type, 1));
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
|
|
build_int_cst (type, 1), tmp);
|
|
se->expr = tmp;
|
|
return;
|
|
}
|
|
else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
|
|
{
|
|
/* Here v is +/- 2**e. The further simplification uses
|
|
2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
|
|
1<<(4*n), etc., but we have to make sure to return zero
|
|
if the number of bits is too large. */
|
|
tree lshift;
|
|
tree type;
|
|
tree shift;
|
|
tree ge;
|
|
tree cond;
|
|
tree num_bits;
|
|
tree cond2;
|
|
tree tmp1;
|
|
|
|
type = TREE_TYPE (lse.expr);
|
|
|
|
if (w == 2)
|
|
shift = rse.expr;
|
|
else if (w == 4)
|
|
shift = fold_build2_loc (input_location, PLUS_EXPR,
|
|
TREE_TYPE (rse.expr),
|
|
rse.expr, rse.expr);
|
|
else
|
|
{
|
|
/* use popcount for fast log2(w) */
|
|
int e = wi::popcount (w-1);
|
|
shift = fold_build2_loc (input_location, MULT_EXPR,
|
|
TREE_TYPE (rse.expr),
|
|
build_int_cst (TREE_TYPE (rse.expr), e),
|
|
rse.expr);
|
|
}
|
|
|
|
lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
|
|
build_int_cst (type, 1), shift);
|
|
ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
|
|
rse.expr, build_int_cst (type, 0));
|
|
cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
|
|
build_int_cst (type, 0));
|
|
num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
|
|
cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
|
|
rse.expr, num_bits);
|
|
tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
|
|
build_int_cst (type, 0), cond);
|
|
if (v > 0)
|
|
{
|
|
se->expr = tmp1;
|
|
}
|
|
else
|
|
{
|
|
/* for v < 0, calculate v**n = |v|**n * (-1)**n */
|
|
tree tmp2;
|
|
tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
|
|
rse.expr, build_int_cst (type, 1));
|
|
tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
|
|
tmp2, build_int_cst (type, 1));
|
|
tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
|
|
build_int_cst (type, 1), tmp2);
|
|
se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
|
|
tmp1, tmp2);
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
|
|
gfc_int4_type_node = gfc_get_int_type (4);
|
|
|
|
/* In case of integer operands with kinds 1 or 2, we call the integer kind 4
|
|
library routine. But in the end, we have to convert the result back
|
|
if this case applies -- with res_ikind_K, we keep track whether operand K
|
|
falls into this case. */
|
|
res_ikind_1 = -1;
|
|
res_ikind_2 = -1;
|
|
|
|
kind = expr->value.op.op1->ts.kind;
|
|
switch (expr->value.op.op2->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
ikind = expr->value.op.op2->ts.kind;
|
|
switch (ikind)
|
|
{
|
|
case 1:
|
|
case 2:
|
|
rse.expr = convert (gfc_int4_type_node, rse.expr);
|
|
res_ikind_2 = ikind;
|
|
/* Fall through. */
|
|
|
|
case 4:
|
|
ikind = 0;
|
|
break;
|
|
|
|
case 8:
|
|
ikind = 1;
|
|
break;
|
|
|
|
case 16:
|
|
ikind = 2;
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
switch (kind)
|
|
{
|
|
case 1:
|
|
case 2:
|
|
if (expr->value.op.op1->ts.type == BT_INTEGER)
|
|
{
|
|
lse.expr = convert (gfc_int4_type_node, lse.expr);
|
|
res_ikind_1 = kind;
|
|
}
|
|
else
|
|
gcc_unreachable ();
|
|
/* Fall through. */
|
|
|
|
case 4:
|
|
kind = 0;
|
|
break;
|
|
|
|
case 8:
|
|
kind = 1;
|
|
break;
|
|
|
|
case 10:
|
|
kind = 2;
|
|
break;
|
|
|
|
case 16:
|
|
kind = 3;
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
switch (expr->value.op.op1->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
if (kind == 3) /* Case 16 was not handled properly above. */
|
|
kind = 2;
|
|
fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
|
|
break;
|
|
|
|
case BT_REAL:
|
|
/* Use builtins for real ** int4. */
|
|
if (ikind == 0)
|
|
{
|
|
switch (kind)
|
|
{
|
|
case 0:
|
|
fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
|
|
break;
|
|
|
|
case 1:
|
|
fndecl = builtin_decl_explicit (BUILT_IN_POWI);
|
|
break;
|
|
|
|
case 2:
|
|
fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
|
|
break;
|
|
|
|
case 3:
|
|
/* Use the __builtin_powil() only if real(kind=16) is
|
|
actually the C long double type. */
|
|
if (!gfc_real16_is_float128)
|
|
fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
}
|
|
|
|
/* If we don't have a good builtin for this, go for the
|
|
library function. */
|
|
if (!fndecl)
|
|
fndecl = gfor_fndecl_math_powi[kind][ikind].real;
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
break;
|
|
|
|
case BT_REAL:
|
|
fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
|
|
se->expr = build_call_expr_loc (input_location,
|
|
fndecl, 2, lse.expr, rse.expr);
|
|
|
|
/* Convert the result back if it is of wrong integer kind. */
|
|
if (res_ikind_1 != -1 && res_ikind_2 != -1)
|
|
{
|
|
/* We want the maximum of both operand kinds as result. */
|
|
if (res_ikind_1 < res_ikind_2)
|
|
res_ikind_1 = res_ikind_2;
|
|
se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
|
|
}
|
|
}
|
|
|
|
|
|
/* Generate code to allocate a string temporary. */
|
|
|
|
tree
|
|
gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
|
|
{
|
|
tree var;
|
|
tree tmp;
|
|
|
|
if (gfc_can_put_var_on_stack (len))
|
|
{
|
|
/* Create a temporary variable to hold the result. */
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
TREE_TYPE (len), len,
|
|
build_int_cst (TREE_TYPE (len), 1));
|
|
tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
|
|
|
|
if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
|
|
tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
|
|
else
|
|
tmp = build_array_type (TREE_TYPE (type), tmp);
|
|
|
|
var = gfc_create_var (tmp, "str");
|
|
var = gfc_build_addr_expr (type, var);
|
|
}
|
|
else
|
|
{
|
|
/* Allocate a temporary to hold the result. */
|
|
var = gfc_create_var (type, "pstr");
|
|
gcc_assert (POINTER_TYPE_P (type));
|
|
tmp = TREE_TYPE (type);
|
|
if (TREE_CODE (tmp) == ARRAY_TYPE)
|
|
tmp = TREE_TYPE (tmp);
|
|
tmp = TYPE_SIZE_UNIT (tmp);
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
|
|
fold_convert (size_type_node, len),
|
|
fold_convert (size_type_node, tmp));
|
|
tmp = gfc_call_malloc (&se->pre, type, tmp);
|
|
gfc_add_modify (&se->pre, var, tmp);
|
|
|
|
/* Free the temporary afterwards. */
|
|
tmp = gfc_call_free (var);
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
}
|
|
|
|
return var;
|
|
}
|
|
|
|
|
|
/* Handle a string concatenation operation. A temporary will be allocated to
|
|
hold the result. */
|
|
|
|
static void
|
|
gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_se lse, rse;
|
|
tree len, type, var, tmp, fndecl;
|
|
|
|
gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
|
|
&& expr->value.op.op2->ts.type == BT_CHARACTER);
|
|
gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
|
|
|
|
gfc_init_se (&lse, se);
|
|
gfc_conv_expr (&lse, expr->value.op.op1);
|
|
gfc_conv_string_parameter (&lse);
|
|
gfc_init_se (&rse, se);
|
|
gfc_conv_expr (&rse, expr->value.op.op2);
|
|
gfc_conv_string_parameter (&rse);
|
|
|
|
gfc_add_block_to_block (&se->pre, &lse.pre);
|
|
gfc_add_block_to_block (&se->pre, &rse.pre);
|
|
|
|
type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
|
|
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
|
|
if (len == NULL_TREE)
|
|
{
|
|
len = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_charlen_type_node,
|
|
fold_convert (gfc_charlen_type_node,
|
|
lse.string_length),
|
|
fold_convert (gfc_charlen_type_node,
|
|
rse.string_length));
|
|
}
|
|
|
|
type = build_pointer_type (type);
|
|
|
|
var = gfc_conv_string_tmp (se, type, len);
|
|
|
|
/* Do the actual concatenation. */
|
|
if (expr->ts.kind == 1)
|
|
fndecl = gfor_fndecl_concat_string;
|
|
else if (expr->ts.kind == 4)
|
|
fndecl = gfor_fndecl_concat_string_char4;
|
|
else
|
|
gcc_unreachable ();
|
|
|
|
tmp = build_call_expr_loc (input_location,
|
|
fndecl, 6, len, var, lse.string_length, lse.expr,
|
|
rse.string_length, rse.expr);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
|
/* Add the cleanup for the operands. */
|
|
gfc_add_block_to_block (&se->pre, &rse.post);
|
|
gfc_add_block_to_block (&se->pre, &lse.post);
|
|
|
|
se->expr = var;
|
|
se->string_length = len;
|
|
}
|
|
|
|
/* Translates an op expression. Common (binary) cases are handled by this
|
|
function, others are passed on. Recursion is used in either case.
|
|
We use the fact that (op1.ts == op2.ts) (except for the power
|
|
operator **).
|
|
Operators need no special handling for scalarized expressions as long as
|
|
they call gfc_conv_simple_val to get their operands.
|
|
Character strings get special handling. */
|
|
|
|
static void
|
|
gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
enum tree_code code;
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
tree tmp, type;
|
|
int lop;
|
|
int checkstring;
|
|
|
|
checkstring = 0;
|
|
lop = 0;
|
|
switch (expr->value.op.op)
|
|
{
|
|
case INTRINSIC_PARENTHESES:
|
|
if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
|
|
&& flag_protect_parens)
|
|
{
|
|
gfc_conv_unary_op (PAREN_EXPR, se, expr);
|
|
gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
|
|
return;
|
|
}
|
|
|
|
/* Fallthrough. */
|
|
case INTRINSIC_UPLUS:
|
|
gfc_conv_expr (se, expr->value.op.op1);
|
|
return;
|
|
|
|
case INTRINSIC_UMINUS:
|
|
gfc_conv_unary_op (NEGATE_EXPR, se, expr);
|
|
return;
|
|
|
|
case INTRINSIC_NOT:
|
|
gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
|
|
return;
|
|
|
|
case INTRINSIC_PLUS:
|
|
code = PLUS_EXPR;
|
|
break;
|
|
|
|
case INTRINSIC_MINUS:
|
|
code = MINUS_EXPR;
|
|
break;
|
|
|
|
case INTRINSIC_TIMES:
|
|
code = MULT_EXPR;
|
|
break;
|
|
|
|
case INTRINSIC_DIVIDE:
|
|
/* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
|
|
an integer, we must round towards zero, so we use a
|
|
TRUNC_DIV_EXPR. */
|
|
if (expr->ts.type == BT_INTEGER)
|
|
code = TRUNC_DIV_EXPR;
|
|
else
|
|
code = RDIV_EXPR;
|
|
break;
|
|
|
|
case INTRINSIC_POWER:
|
|
gfc_conv_power_op (se, expr);
|
|
return;
|
|
|
|
case INTRINSIC_CONCAT:
|
|
gfc_conv_concat_op (se, expr);
|
|
return;
|
|
|
|
case INTRINSIC_AND:
|
|
code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_OR:
|
|
code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
|
|
lop = 1;
|
|
break;
|
|
|
|
/* EQV and NEQV only work on logicals, but since we represent them
|
|
as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
|
|
case INTRINSIC_EQ:
|
|
case INTRINSIC_EQ_OS:
|
|
case INTRINSIC_EQV:
|
|
code = EQ_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_NE:
|
|
case INTRINSIC_NE_OS:
|
|
case INTRINSIC_NEQV:
|
|
code = NE_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_GT:
|
|
case INTRINSIC_GT_OS:
|
|
code = GT_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_GE:
|
|
case INTRINSIC_GE_OS:
|
|
code = GE_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_LT:
|
|
case INTRINSIC_LT_OS:
|
|
code = LT_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_LE:
|
|
case INTRINSIC_LE_OS:
|
|
code = LE_EXPR;
|
|
checkstring = 1;
|
|
lop = 1;
|
|
break;
|
|
|
|
case INTRINSIC_USER:
|
|
case INTRINSIC_ASSIGN:
|
|
/* These should be converted into function calls by the frontend. */
|
|
gcc_unreachable ();
|
|
|
|
default:
|
|
fatal_error (input_location, "Unknown intrinsic op");
|
|
return;
|
|
}
|
|
|
|
/* The only exception to this is **, which is handled separately anyway. */
|
|
gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
|
|
|
|
if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
|
|
checkstring = 0;
|
|
|
|
/* lhs */
|
|
gfc_init_se (&lse, se);
|
|
gfc_conv_expr (&lse, expr->value.op.op1);
|
|
gfc_add_block_to_block (&se->pre, &lse.pre);
|
|
|
|
/* rhs */
|
|
gfc_init_se (&rse, se);
|
|
gfc_conv_expr (&rse, expr->value.op.op2);
|
|
gfc_add_block_to_block (&se->pre, &rse.pre);
|
|
|
|
if (checkstring)
|
|
{
|
|
gfc_conv_string_parameter (&lse);
|
|
gfc_conv_string_parameter (&rse);
|
|
|
|
lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
|
|
rse.string_length, rse.expr,
|
|
expr->value.op.op1->ts.kind,
|
|
code);
|
|
rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
|
|
gfc_add_block_to_block (&lse.post, &rse.post);
|
|
}
|
|
|
|
type = gfc_typenode_for_spec (&expr->ts);
|
|
|
|
if (lop)
|
|
{
|
|
/* The result of logical ops is always logical_type_node. */
|
|
tmp = fold_build2_loc (input_location, code, logical_type_node,
|
|
lse.expr, rse.expr);
|
|
se->expr = convert (type, tmp);
|
|
}
|
|
else
|
|
se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
|
|
|
|
/* Add the post blocks. */
|
|
gfc_add_block_to_block (&se->post, &rse.post);
|
|
gfc_add_block_to_block (&se->post, &lse.post);
|
|
}
|
|
|
|
/* If a string's length is one, we convert it to a single character. */
|
|
|
|
tree
|
|
gfc_string_to_single_character (tree len, tree str, int kind)
|
|
{
|
|
|
|
if (len == NULL
|
|
|| !tree_fits_uhwi_p (len)
|
|
|| !POINTER_TYPE_P (TREE_TYPE (str)))
|
|
return NULL_TREE;
|
|
|
|
if (TREE_INT_CST_LOW (len) == 1)
|
|
{
|
|
str = fold_convert (gfc_get_pchar_type (kind), str);
|
|
return build_fold_indirect_ref_loc (input_location, str);
|
|
}
|
|
|
|
if (kind == 1
|
|
&& TREE_CODE (str) == ADDR_EXPR
|
|
&& TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
|
|
&& TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
|
|
&& array_ref_low_bound (TREE_OPERAND (str, 0))
|
|
== TREE_OPERAND (TREE_OPERAND (str, 0), 1)
|
|
&& TREE_INT_CST_LOW (len) > 1
|
|
&& TREE_INT_CST_LOW (len)
|
|
== (unsigned HOST_WIDE_INT)
|
|
TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
|
|
{
|
|
tree ret = fold_convert (gfc_get_pchar_type (kind), str);
|
|
ret = build_fold_indirect_ref_loc (input_location, ret);
|
|
if (TREE_CODE (ret) == INTEGER_CST)
|
|
{
|
|
tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
|
|
int i, length = TREE_STRING_LENGTH (string_cst);
|
|
const char *ptr = TREE_STRING_POINTER (string_cst);
|
|
|
|
for (i = 1; i < length; i++)
|
|
if (ptr[i] != ' ')
|
|
return NULL_TREE;
|
|
|
|
return ret;
|
|
}
|
|
}
|
|
|
|
return NULL_TREE;
|
|
}
|
|
|
|
|
|
static void
|
|
conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
|
|
{
|
|
gcc_assert (expr);
|
|
|
|
/* We used to modify the tree here. Now it is done earlier in
|
|
the front-end, so we only check it here to avoid regressions. */
|
|
if (sym->backend_decl)
|
|
{
|
|
gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
|
|
gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
|
|
gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
|
|
gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
|
|
}
|
|
|
|
/* If we have a constant character expression, make it into an
|
|
integer of type C char. */
|
|
if ((*expr)->expr_type == EXPR_CONSTANT)
|
|
{
|
|
gfc_typespec ts;
|
|
gfc_clear_ts (&ts);
|
|
|
|
*expr = gfc_get_int_expr (gfc_default_character_kind, NULL,
|
|
(*expr)->value.character.string[0]);
|
|
}
|
|
else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
|
|
{
|
|
if ((*expr)->ref == NULL)
|
|
{
|
|
se->expr = gfc_string_to_single_character
|
|
(build_int_cst (integer_type_node, 1),
|
|
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
|
|
gfc_get_symbol_decl
|
|
((*expr)->symtree->n.sym)),
|
|
(*expr)->ts.kind);
|
|
}
|
|
else
|
|
{
|
|
gfc_conv_variable (se, *expr);
|
|
se->expr = gfc_string_to_single_character
|
|
(build_int_cst (integer_type_node, 1),
|
|
gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
|
|
se->expr),
|
|
(*expr)->ts.kind);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* Helper function for gfc_build_compare_string. Return LEN_TRIM value
|
|
if STR is a string literal, otherwise return -1. */
|
|
|
|
static int
|
|
gfc_optimize_len_trim (tree len, tree str, int kind)
|
|
{
|
|
if (kind == 1
|
|
&& TREE_CODE (str) == ADDR_EXPR
|
|
&& TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
|
|
&& TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
|
|
&& array_ref_low_bound (TREE_OPERAND (str, 0))
|
|
== TREE_OPERAND (TREE_OPERAND (str, 0), 1)
|
|
&& tree_fits_uhwi_p (len)
|
|
&& tree_to_uhwi (len) >= 1
|
|
&& tree_to_uhwi (len)
|
|
== (unsigned HOST_WIDE_INT)
|
|
TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
|
|
{
|
|
tree folded = fold_convert (gfc_get_pchar_type (kind), str);
|
|
folded = build_fold_indirect_ref_loc (input_location, folded);
|
|
if (TREE_CODE (folded) == INTEGER_CST)
|
|
{
|
|
tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
|
|
int length = TREE_STRING_LENGTH (string_cst);
|
|
const char *ptr = TREE_STRING_POINTER (string_cst);
|
|
|
|
for (; length > 0; length--)
|
|
if (ptr[length - 1] != ' ')
|
|
break;
|
|
|
|
return length;
|
|
}
|
|
}
|
|
return -1;
|
|
}
|
|
|
|
/* Helper to build a call to memcmp. */
|
|
|
|
static tree
|
|
build_memcmp_call (tree s1, tree s2, tree n)
|
|
{
|
|
tree tmp;
|
|
|
|
if (!POINTER_TYPE_P (TREE_TYPE (s1)))
|
|
s1 = gfc_build_addr_expr (pvoid_type_node, s1);
|
|
else
|
|
s1 = fold_convert (pvoid_type_node, s1);
|
|
|
|
if (!POINTER_TYPE_P (TREE_TYPE (s2)))
|
|
s2 = gfc_build_addr_expr (pvoid_type_node, s2);
|
|
else
|
|
s2 = fold_convert (pvoid_type_node, s2);
|
|
|
|
n = fold_convert (size_type_node, n);
|
|
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMCMP),
|
|
3, s1, s2, n);
|
|
|
|
return fold_convert (integer_type_node, tmp);
|
|
}
|
|
|
|
/* Compare two strings. If they are all single characters, the result is the
|
|
subtraction of them. Otherwise, we build a library call. */
|
|
|
|
tree
|
|
gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
|
|
enum tree_code code)
|
|
{
|
|
tree sc1;
|
|
tree sc2;
|
|
tree fndecl;
|
|
|
|
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
|
|
gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
|
|
|
|
sc1 = gfc_string_to_single_character (len1, str1, kind);
|
|
sc2 = gfc_string_to_single_character (len2, str2, kind);
|
|
|
|
if (sc1 != NULL_TREE && sc2 != NULL_TREE)
|
|
{
|
|
/* Deal with single character specially. */
|
|
sc1 = fold_convert (integer_type_node, sc1);
|
|
sc2 = fold_convert (integer_type_node, sc2);
|
|
return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
|
|
sc1, sc2);
|
|
}
|
|
|
|
if ((code == EQ_EXPR || code == NE_EXPR)
|
|
&& optimize
|
|
&& INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
|
|
{
|
|
/* If one string is a string literal with LEN_TRIM longer
|
|
than the length of the second string, the strings
|
|
compare unequal. */
|
|
int len = gfc_optimize_len_trim (len1, str1, kind);
|
|
if (len > 0 && compare_tree_int (len2, len) < 0)
|
|
return integer_one_node;
|
|
len = gfc_optimize_len_trim (len2, str2, kind);
|
|
if (len > 0 && compare_tree_int (len1, len) < 0)
|
|
return integer_one_node;
|
|
}
|
|
|
|
/* We can compare via memcpy if the strings are known to be equal
|
|
in length and they are
|
|
- kind=1
|
|
- kind=4 and the comparison is for (in)equality. */
|
|
|
|
if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
|
|
&& tree_int_cst_equal (len1, len2)
|
|
&& (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
|
|
{
|
|
tree tmp;
|
|
tree chartype;
|
|
|
|
chartype = gfc_get_char_type (kind);
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
|
|
fold_convert (TREE_TYPE(len1),
|
|
TYPE_SIZE_UNIT(chartype)),
|
|
len1);
|
|
return build_memcmp_call (str1, str2, tmp);
|
|
}
|
|
|
|
/* Build a call for the comparison. */
|
|
if (kind == 1)
|
|
fndecl = gfor_fndecl_compare_string;
|
|
else if (kind == 4)
|
|
fndecl = gfor_fndecl_compare_string_char4;
|
|
else
|
|
gcc_unreachable ();
|
|
|
|
return build_call_expr_loc (input_location, fndecl, 4,
|
|
len1, str1, len2, str2);
|
|
}
|
|
|
|
|
|
/* Return the backend_decl for a procedure pointer component. */
|
|
|
|
static tree
|
|
get_proc_ptr_comp (gfc_expr *e)
|
|
{
|
|
gfc_se comp_se;
|
|
gfc_expr *e2;
|
|
expr_t old_type;
|
|
|
|
gfc_init_se (&comp_se, NULL);
|
|
e2 = gfc_copy_expr (e);
|
|
/* We have to restore the expr type later so that gfc_free_expr frees
|
|
the exact same thing that was allocated.
|
|
TODO: This is ugly. */
|
|
old_type = e2->expr_type;
|
|
e2->expr_type = EXPR_VARIABLE;
|
|
gfc_conv_expr (&comp_se, e2);
|
|
e2->expr_type = old_type;
|
|
gfc_free_expr (e2);
|
|
return build_fold_addr_expr_loc (input_location, comp_se.expr);
|
|
}
|
|
|
|
|
|
/* Convert a typebound function reference from a class object. */
|
|
static void
|
|
conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
|
|
{
|
|
gfc_ref *ref;
|
|
tree var;
|
|
|
|
if (!VAR_P (base_object))
|
|
{
|
|
var = gfc_create_var (TREE_TYPE (base_object), NULL);
|
|
gfc_add_modify (&se->pre, var, base_object);
|
|
}
|
|
se->expr = gfc_class_vptr_get (base_object);
|
|
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
|
|
ref = expr->ref;
|
|
while (ref && ref->next)
|
|
ref = ref->next;
|
|
gcc_assert (ref && ref->type == REF_COMPONENT);
|
|
if (ref->u.c.sym->attr.extension)
|
|
conv_parent_component_references (se, ref);
|
|
gfc_conv_component_ref (se, ref);
|
|
se->expr = build_fold_addr_expr_loc (input_location, se->expr);
|
|
}
|
|
|
|
|
|
static void
|
|
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
|
|
gfc_actual_arglist *actual_args)
|
|
{
|
|
tree tmp;
|
|
|
|
if (gfc_is_proc_ptr_comp (expr))
|
|
tmp = get_proc_ptr_comp (expr);
|
|
else if (sym->attr.dummy)
|
|
{
|
|
tmp = gfc_get_symbol_decl (sym);
|
|
if (sym->attr.proc_pointer)
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
tmp);
|
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
|
|
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
|
|
}
|
|
else
|
|
{
|
|
if (!sym->backend_decl)
|
|
sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
|
|
|
|
TREE_USED (sym->backend_decl) = 1;
|
|
|
|
tmp = sym->backend_decl;
|
|
|
|
if (sym->attr.cray_pointee)
|
|
{
|
|
/* TODO - make the cray pointee a pointer to a procedure,
|
|
assign the pointer to it and use it for the call. This
|
|
will do for now! */
|
|
tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
|
|
gfc_get_symbol_decl (sym->cp_pointer));
|
|
tmp = gfc_evaluate_now (tmp, &se->pre);
|
|
}
|
|
|
|
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
|
|
{
|
|
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
|
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
}
|
|
}
|
|
se->expr = tmp;
|
|
}
|
|
|
|
|
|
/* Initialize MAPPING. */
|
|
|
|
void
|
|
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
|
{
|
|
mapping->syms = NULL;
|
|
mapping->charlens = NULL;
|
|
}
|
|
|
|
|
|
/* Free all memory held by MAPPING (but not MAPPING itself). */
|
|
|
|
void
|
|
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
|
|
{
|
|
gfc_interface_sym_mapping *sym;
|
|
gfc_interface_sym_mapping *nextsym;
|
|
gfc_charlen *cl;
|
|
gfc_charlen *nextcl;
|
|
|
|
for (sym = mapping->syms; sym; sym = nextsym)
|
|
{
|
|
nextsym = sym->next;
|
|
sym->new_sym->n.sym->formal = NULL;
|
|
gfc_free_symbol (sym->new_sym->n.sym);
|
|
gfc_free_expr (sym->expr);
|
|
free (sym->new_sym);
|
|
free (sym);
|
|
}
|
|
for (cl = mapping->charlens; cl; cl = nextcl)
|
|
{
|
|
nextcl = cl->next;
|
|
gfc_free_expr (cl->length);
|
|
free (cl);
|
|
}
|
|
}
|
|
|
|
|
|
/* Return a copy of gfc_charlen CL. Add the returned structure to
|
|
MAPPING so that it will be freed by gfc_free_interface_mapping. */
|
|
|
|
static gfc_charlen *
|
|
gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
|
|
gfc_charlen * cl)
|
|
{
|
|
gfc_charlen *new_charlen;
|
|
|
|
new_charlen = gfc_get_charlen ();
|
|
new_charlen->next = mapping->charlens;
|
|
new_charlen->length = gfc_copy_expr (cl->length);
|
|
|
|
mapping->charlens = new_charlen;
|
|
return new_charlen;
|
|
}
|
|
|
|
|
|
/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
|
|
array variable that can be used as the actual argument for dummy
|
|
argument SYM. Add any initialization code to BLOCK. PACKED is as
|
|
for gfc_get_nodesc_array_type and DATA points to the first element
|
|
in the passed array. */
|
|
|
|
static tree
|
|
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
|
|
gfc_packed packed, tree data)
|
|
{
|
|
tree type;
|
|
tree var;
|
|
|
|
type = gfc_typenode_for_spec (&sym->ts);
|
|
type = gfc_get_nodesc_array_type (type, sym->as, packed,
|
|
!sym->attr.target && !sym->attr.pointer
|
|
&& !sym->attr.proc_pointer);
|
|
|
|
var = gfc_create_var (type, "ifm");
|
|
gfc_add_modify (block, var, fold_convert (type, data));
|
|
|
|
return var;
|
|
}
|
|
|
|
|
|
/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
|
|
and offset of descriptorless array type TYPE given that it has the same
|
|
size as DESC. Add any set-up code to BLOCK. */
|
|
|
|
static void
|
|
gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
|
|
{
|
|
int n;
|
|
tree dim;
|
|
tree offset;
|
|
tree tmp;
|
|
|
|
offset = gfc_index_zero_node;
|
|
for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
|
|
{
|
|
dim = gfc_rank_cst[n];
|
|
GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
|
|
if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
|
|
{
|
|
GFC_TYPE_ARRAY_LBOUND (type, n)
|
|
= gfc_conv_descriptor_lbound_get (desc, dim);
|
|
GFC_TYPE_ARRAY_UBOUND (type, n)
|
|
= gfc_conv_descriptor_ubound_get (desc, dim);
|
|
}
|
|
else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
|
|
{
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
gfc_conv_descriptor_ubound_get (desc, dim),
|
|
gfc_conv_descriptor_lbound_get (desc, dim));
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type,
|
|
GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
|
|
tmp = gfc_evaluate_now (tmp, block);
|
|
GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
|
|
}
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
GFC_TYPE_ARRAY_LBOUND (type, n),
|
|
GFC_TYPE_ARRAY_STRIDE (type, n));
|
|
offset = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type, offset, tmp);
|
|
}
|
|
offset = gfc_evaluate_now (offset, block);
|
|
GFC_TYPE_ARRAY_OFFSET (type) = offset;
|
|
}
|
|
|
|
|
|
/* Extend MAPPING so that it maps dummy argument SYM to the value stored
|
|
in SE. The caller may still use se->expr and se->string_length after
|
|
calling this function. */
|
|
|
|
void
|
|
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
|
gfc_symbol * sym, gfc_se * se,
|
|
gfc_expr *expr)
|
|
{
|
|
gfc_interface_sym_mapping *sm;
|
|
tree desc;
|
|
tree tmp;
|
|
tree value;
|
|
gfc_symbol *new_sym;
|
|
gfc_symtree *root;
|
|
gfc_symtree *new_symtree;
|
|
|
|
/* Create a new symbol to represent the actual argument. */
|
|
new_sym = gfc_new_symbol (sym->name, NULL);
|
|
new_sym->ts = sym->ts;
|
|
new_sym->as = gfc_copy_array_spec (sym->as);
|
|
new_sym->attr.referenced = 1;
|
|
new_sym->attr.dimension = sym->attr.dimension;
|
|
new_sym->attr.contiguous = sym->attr.contiguous;
|
|
new_sym->attr.codimension = sym->attr.codimension;
|
|
new_sym->attr.pointer = sym->attr.pointer;
|
|
new_sym->attr.allocatable = sym->attr.allocatable;
|
|
new_sym->attr.flavor = sym->attr.flavor;
|
|
new_sym->attr.function = sym->attr.function;
|
|
|
|
/* Ensure that the interface is available and that
|
|
descriptors are passed for array actual arguments. */
|
|
if (sym->attr.flavor == FL_PROCEDURE)
|
|
{
|
|
new_sym->formal = expr->symtree->n.sym->formal;
|
|
new_sym->attr.always_explicit
|
|
= expr->symtree->n.sym->attr.always_explicit;
|
|
}
|
|
|
|
/* Create a fake symtree for it. */
|
|
root = NULL;
|
|
new_symtree = gfc_new_symtree (&root, sym->name);
|
|
new_symtree->n.sym = new_sym;
|
|
gcc_assert (new_symtree == root);
|
|
|
|
/* Create a dummy->actual mapping. */
|
|
sm = XCNEW (gfc_interface_sym_mapping);
|
|
sm->next = mapping->syms;
|
|
sm->old = sym;
|
|
sm->new_sym = new_symtree;
|
|
sm->expr = gfc_copy_expr (expr);
|
|
mapping->syms = sm;
|
|
|
|
/* Stabilize the argument's value. */
|
|
if (!sym->attr.function && se)
|
|
se->expr = gfc_evaluate_now (se->expr, &se->pre);
|
|
|
|
if (sym->ts.type == BT_CHARACTER)
|
|
{
|
|
/* Create a copy of the dummy argument's length. */
|
|
new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
|
|
sm->expr->ts.u.cl = new_sym->ts.u.cl;
|
|
|
|
/* If the length is specified as "*", record the length that
|
|
the caller is passing. We should use the callee's length
|
|
in all other cases. */
|
|
if (!new_sym->ts.u.cl->length && se)
|
|
{
|
|
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
|
|
new_sym->ts.u.cl->backend_decl = se->string_length;
|
|
}
|
|
}
|
|
|
|
if (!se)
|
|
return;
|
|
|
|
/* Use the passed value as-is if the argument is a function. */
|
|
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)
|
|
{
|
|
tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
|
|
tmp = build_pointer_type (tmp);
|
|
if (sym->attr.pointer)
|
|
value = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
else
|
|
value = se->expr;
|
|
value = fold_convert (tmp, value);
|
|
}
|
|
|
|
/* If the argument is a scalar, a pointer to an array or an allocatable,
|
|
dereference it. */
|
|
else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
|
|
value = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
|
|
/* For character(*), use the actual argument's descriptor. */
|
|
else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
|
|
value = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
|
|
/* If the argument is an array descriptor, use it to determine
|
|
information about the actual argument's shape. */
|
|
else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
|
|
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
|
|
{
|
|
/* Get the actual argument's descriptor. */
|
|
desc = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
|
|
/* Create the replacement variable. */
|
|
tmp = gfc_conv_descriptor_data_get (desc);
|
|
value = gfc_get_interface_mapping_array (&se->pre, sym,
|
|
PACKED_NO, tmp);
|
|
|
|
/* Use DESC to work out the upper bounds, strides and offset. */
|
|
gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
|
|
}
|
|
else
|
|
/* Otherwise we have a packed array. */
|
|
value = gfc_get_interface_mapping_array (&se->pre, sym,
|
|
PACKED_FULL, se->expr);
|
|
|
|
new_sym->backend_decl = value;
|
|
}
|
|
|
|
|
|
/* Called once all dummy argument mappings have been added to MAPPING,
|
|
but before the mapping is used to evaluate expressions. Pre-evaluate
|
|
the length of each argument, adding any initialization code to PRE and
|
|
any finalization code to POST. */
|
|
|
|
static void
|
|
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
|
|
stmtblock_t * pre, stmtblock_t * post)
|
|
{
|
|
gfc_interface_sym_mapping *sym;
|
|
gfc_expr *expr;
|
|
gfc_se se;
|
|
|
|
for (sym = mapping->syms; sym; sym = sym->next)
|
|
if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
|
|
&& !sym->new_sym->n.sym->ts.u.cl->backend_decl)
|
|
{
|
|
expr = sym->new_sym->n.sym->ts.u.cl->length;
|
|
gfc_apply_interface_mapping_to_expr (mapping, expr);
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_expr (&se, expr);
|
|
se.expr = fold_convert (gfc_charlen_type_node, se.expr);
|
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
|
gfc_add_block_to_block (pre, &se.pre);
|
|
gfc_add_block_to_block (post, &se.post);
|
|
|
|
sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
|
|
}
|
|
}
|
|
|
|
|
|
/* Like gfc_apply_interface_mapping_to_expr, but applied to
|
|
constructor C. */
|
|
|
|
static void
|
|
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
|
|
gfc_constructor_base base)
|
|
{
|
|
gfc_constructor *c;
|
|
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
|
|
{
|
|
gfc_apply_interface_mapping_to_expr (mapping, c->expr);
|
|
if (c->iterator)
|
|
{
|
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
|
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
|
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
/* Like gfc_apply_interface_mapping_to_expr, but applied to
|
|
reference REF. */
|
|
|
|
static void
|
|
gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
|
|
gfc_ref * ref)
|
|
{
|
|
int n;
|
|
|
|
for (; ref; ref = ref->next)
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
|
{
|
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
|
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
|
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
|
|
}
|
|
break;
|
|
|
|
case REF_COMPONENT:
|
|
case REF_INQUIRY:
|
|
break;
|
|
|
|
case REF_SUBSTRING:
|
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
|
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
/* Convert intrinsic function calls into result expressions. */
|
|
|
|
static bool
|
|
gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
|
|
{
|
|
gfc_symbol *sym;
|
|
gfc_expr *new_expr;
|
|
gfc_expr *arg1;
|
|
gfc_expr *arg2;
|
|
int d, dup;
|
|
|
|
arg1 = expr->value.function.actual->expr;
|
|
if (expr->value.function.actual->next)
|
|
arg2 = expr->value.function.actual->next->expr;
|
|
else
|
|
arg2 = NULL;
|
|
|
|
sym = arg1->symtree->n.sym;
|
|
|
|
if (sym->attr.dummy)
|
|
return false;
|
|
|
|
new_expr = NULL;
|
|
|
|
switch (expr->value.function.isym->id)
|
|
{
|
|
case GFC_ISYM_LEN:
|
|
/* TODO figure out why this condition is necessary. */
|
|
if (sym->attr.function
|
|
&& (arg1->ts.u.cl->length == NULL
|
|
|| (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
|
|
&& arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
|
|
return false;
|
|
|
|
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;
|
|
|
|
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
|
|
{
|
|
dup = mpz_get_si (arg2->value.integer);
|
|
d = dup - 1;
|
|
}
|
|
else
|
|
{
|
|
dup = sym->as->rank;
|
|
d = 0;
|
|
}
|
|
|
|
for (; d < dup; d++)
|
|
{
|
|
gfc_expr *tmp;
|
|
|
|
if (!sym->as->upper[d] || !sym->as->lower[d])
|
|
{
|
|
gfc_free_expr (new_expr);
|
|
return false;
|
|
}
|
|
|
|
tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
|
|
gfc_get_int_expr (gfc_default_integer_kind,
|
|
NULL, 1));
|
|
tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
|
|
if (new_expr)
|
|
new_expr = gfc_multiply (new_expr, tmp);
|
|
else
|
|
new_expr = tmp;
|
|
}
|
|
break;
|
|
|
|
case GFC_ISYM_LBOUND:
|
|
case GFC_ISYM_UBOUND:
|
|
/* TODO These implementations of lbound and ubound do not limit if
|
|
the size < 0, according to F95's 13.14.53 and 13.14.113. */
|
|
|
|
if (!sym->as || sym->as->rank == 0)
|
|
return false;
|
|
|
|
if (arg2 && arg2->expr_type == EXPR_CONSTANT)
|
|
d = mpz_get_si (arg2->value.integer) - 1;
|
|
else
|
|
return false;
|
|
|
|
if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
|
|
{
|
|
if (sym->as->lower[d])
|
|
new_expr = gfc_copy_expr (sym->as->lower[d]);
|
|
}
|
|
else
|
|
{
|
|
if (sym->as->upper[d])
|
|
new_expr = gfc_copy_expr (sym->as->upper[d]);
|
|
}
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
|
|
gfc_apply_interface_mapping_to_expr (mapping, new_expr);
|
|
if (!new_expr)
|
|
return false;
|
|
|
|
gfc_replace_expr (expr, new_expr);
|
|
return true;
|
|
}
|
|
|
|
|
|
static void
|
|
gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
|
|
gfc_interface_mapping * mapping)
|
|
{
|
|
gfc_formal_arglist *f;
|
|
gfc_actual_arglist *actual;
|
|
|
|
actual = expr->value.function.actual;
|
|
f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
|
|
|
|
for (; f && actual; f = f->next, actual = actual->next)
|
|
{
|
|
if (!actual->expr)
|
|
continue;
|
|
|
|
gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
|
|
}
|
|
|
|
if (map_expr->symtree->n.sym->attr.dimension)
|
|
{
|
|
int d;
|
|
gfc_array_spec *as;
|
|
|
|
as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
|
|
|
|
for (d = 0; d < as->rank; d++)
|
|
{
|
|
gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
|
|
gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
|
|
}
|
|
|
|
expr->value.function.esym->as = as;
|
|
}
|
|
|
|
if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
|
|
{
|
|
expr->value.function.esym->ts.u.cl->length
|
|
= gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
|
|
|
|
gfc_apply_interface_mapping_to_expr (mapping,
|
|
expr->value.function.esym->ts.u.cl->length);
|
|
}
|
|
}
|
|
|
|
|
|
/* EXPR is a copy of an expression that appeared in the interface
|
|
associated with MAPPING. Walk it recursively looking for references to
|
|
dummy arguments that MAPPING maps to actual arguments. Replace each such
|
|
reference with a reference to the associated actual argument. */
|
|
|
|
static void
|
|
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
|
|
gfc_expr * expr)
|
|
{
|
|
gfc_interface_sym_mapping *sym;
|
|
gfc_actual_arglist *actual;
|
|
|
|
if (!expr)
|
|
return;
|
|
|
|
/* Copying an expression does not copy its length, so do that here. */
|
|
if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
|
|
{
|
|
expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
|
|
gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
|
|
}
|
|
|
|
/* Apply the mapping to any references. */
|
|
gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
|
|
|
|
/* ...and to the expression's symbol, if it has one. */
|
|
/* TODO Find out why the condition on expr->symtree had to be moved into
|
|
the loop rather than being outside it, as originally. */
|
|
for (sym = mapping->syms; sym; sym = sym->next)
|
|
if (expr->symtree && sym->old == expr->symtree->n.sym)
|
|
{
|
|
if (sym->new_sym->n.sym->backend_decl)
|
|
expr->symtree = sym->new_sym;
|
|
else if (sym->expr)
|
|
gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
|
|
}
|
|
|
|
/* ...and to subexpressions in expr->value. */
|
|
switch (expr->expr_type)
|
|
{
|
|
case EXPR_VARIABLE:
|
|
case EXPR_CONSTANT:
|
|
case EXPR_NULL:
|
|
case EXPR_SUBSTRING:
|
|
break;
|
|
|
|
case EXPR_OP:
|
|
gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
|
|
gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
for (actual = expr->value.function.actual; actual; actual = actual->next)
|
|
gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
|
|
|
|
if (expr->value.function.esym == NULL
|
|
&& expr->value.function.isym != NULL
|
|
&& expr->value.function.actual
|
|
&& expr->value.function.actual->expr
|
|
&& expr->value.function.actual->expr->symtree
|
|
&& gfc_map_intrinsic_function (expr, mapping))
|
|
break;
|
|
|
|
for (sym = mapping->syms; sym; sym = sym->next)
|
|
if (sym->old == expr->value.function.esym)
|
|
{
|
|
expr->value.function.esym = sym->new_sym->n.sym;
|
|
gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
|
|
expr->value.function.esym->result = sym->new_sym->n.sym;
|
|
}
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
case EXPR_STRUCTURE:
|
|
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
|
|
break;
|
|
|
|
case EXPR_COMPCALL:
|
|
case EXPR_PPC:
|
|
case EXPR_UNKNOWN:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/* Evaluate interface expression EXPR using MAPPING. Store the result
|
|
in SE. */
|
|
|
|
void
|
|
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
|
|
gfc_se * se, gfc_expr * expr)
|
|
{
|
|
expr = gfc_copy_expr (expr);
|
|
gfc_apply_interface_mapping_to_expr (mapping, expr);
|
|
gfc_conv_expr (se, expr);
|
|
se->expr = gfc_evaluate_now (se->expr, &se->pre);
|
|
gfc_free_expr (expr);
|
|
}
|
|
|
|
|
|
/* Returns a reference to a temporary array into which a component of
|
|
an actual argument derived type array is copied and then returned
|
|
after the function call. */
|
|
void
|
|
gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
|
|
sym_intent intent, bool formal_ptr,
|
|
const gfc_symbol *fsym, const char *proc_name,
|
|
gfc_symbol *sym, bool check_contiguous)
|
|
{
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
gfc_ss *lss;
|
|
gfc_ss *rss;
|
|
gfc_loopinfo loop;
|
|
gfc_loopinfo loop2;
|
|
gfc_array_info *info;
|
|
tree offset;
|
|
tree tmp_index;
|
|
tree tmp;
|
|
tree base_type;
|
|
tree size;
|
|
stmtblock_t body;
|
|
int n;
|
|
int dimen;
|
|
gfc_se work_se;
|
|
gfc_se *parmse;
|
|
bool pass_optional;
|
|
|
|
pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
|
|
|
|
if (pass_optional || check_contiguous)
|
|
{
|
|
gfc_init_se (&work_se, NULL);
|
|
parmse = &work_se;
|
|
}
|
|
else
|
|
parmse = se;
|
|
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
|
|
{
|
|
/* We will create a temporary array, so let us warn. */
|
|
char * msg;
|
|
|
|
if (fsym && proc_name)
|
|
msg = xasprintf ("An array temporary was created for argument "
|
|
"'%s' of procedure '%s'", fsym->name, proc_name);
|
|
else
|
|
msg = xasprintf ("An array temporary was created");
|
|
|
|
tmp = build_int_cst (logical_type_node, 1);
|
|
gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
|
|
&expr->where, msg);
|
|
free (msg);
|
|
}
|
|
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
/* Walk the argument expression. */
|
|
rss = gfc_walk_expr (expr);
|
|
|
|
gcc_assert (rss != gfc_ss_terminator);
|
|
|
|
/* Initialize the scalarizer. */
|
|
gfc_init_loopinfo (&loop);
|
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
|
/* Calculate the bounds of the scalarization. */
|
|
gfc_conv_ss_startstride (&loop);
|
|
|
|
/* Build an ss for the temporary. */
|
|
if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
|
|
gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
|
|
|
|
base_type = gfc_typenode_for_spec (&expr->ts);
|
|
if (GFC_ARRAY_TYPE_P (base_type)
|
|
|| GFC_DESCRIPTOR_TYPE_P (base_type))
|
|
base_type = gfc_get_element_type (base_type);
|
|
|
|
if (expr->ts.type == BT_CLASS)
|
|
base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
|
|
|
|
loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
|
|
? expr->ts.u.cl->backend_decl
|
|
: NULL),
|
|
loop.dimen);
|
|
|
|
parmse->string_length = loop.temp_ss->info->string_length;
|
|
|
|
/* Associate the SS with the loop. */
|
|
gfc_add_ss_to_loop (&loop, loop.temp_ss);
|
|
|
|
/* Setup the scalarizing loops. */
|
|
gfc_conv_loop_setup (&loop, &expr->where);
|
|
|
|
/* Pass the temporary descriptor back to the caller. */
|
|
info = &loop.temp_ss->info->data.array;
|
|
parmse->expr = info->descriptor;
|
|
|
|
/* Setup the gfc_se structures. */
|
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
|
rse.ss = rss;
|
|
lse.ss = loop.temp_ss;
|
|
gfc_mark_ss_chain_used (rss, 1);
|
|
gfc_mark_ss_chain_used (loop.temp_ss, 1);
|
|
|
|
/* Start the scalarized loop body. */
|
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
|
/* Translate the expression. */
|
|
gfc_conv_expr (&rse, expr);
|
|
|
|
/* Reset the offset for the function call since the loop
|
|
is zero based on the data pointer. Note that the temp
|
|
comes first in the loop chain since it is added second. */
|
|
if (gfc_is_class_array_function (expr))
|
|
{
|
|
tmp = loop.ss->loop_chain->info->data.array.descriptor;
|
|
gfc_conv_descriptor_offset_set (&loop.pre, tmp,
|
|
gfc_index_zero_node);
|
|
}
|
|
|
|
gfc_conv_tmp_array_ref (&lse);
|
|
|
|
if (intent != INTENT_OUT)
|
|
{
|
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
|
|
gfc_add_expr_to_block (&body, tmp);
|
|
gcc_assert (rse.ss == gfc_ss_terminator);
|
|
gfc_trans_scalarizing_loops (&loop, &body);
|
|
}
|
|
else
|
|
{
|
|
/* Make sure that the temporary declaration survives by merging
|
|
all the loop declarations into the current context. */
|
|
for (n = 0; n < loop.dimen; n++)
|
|
{
|
|
gfc_merge_block_scope (&body);
|
|
body = loop.code[loop.order[n]];
|
|
}
|
|
gfc_merge_block_scope (&body);
|
|
}
|
|
|
|
/* Add the post block after the second loop, so that any
|
|
freeing of allocated memory is done at the right time. */
|
|
gfc_add_block_to_block (&parmse->pre, &loop.pre);
|
|
|
|
/**********Copy the temporary back again.*********/
|
|
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
/* Walk the argument expression. */
|
|
lss = gfc_walk_expr (expr);
|
|
rse.ss = loop.temp_ss;
|
|
lse.ss = lss;
|
|
|
|
/* Initialize the scalarizer. */
|
|
gfc_init_loopinfo (&loop2);
|
|
gfc_add_ss_to_loop (&loop2, lss);
|
|
|
|
dimen = rse.ss->dimen;
|
|
|
|
/* Skip the write-out loop for this case. */
|
|
if (gfc_is_class_array_function (expr))
|
|
goto class_array_fcn;
|
|
|
|
/* Calculate the bounds of the scalarization. */
|
|
gfc_conv_ss_startstride (&loop2);
|
|
|
|
/* Setup the scalarizing loops. */
|
|
gfc_conv_loop_setup (&loop2, &expr->where);
|
|
|
|
gfc_copy_loopinfo_to_se (&lse, &loop2);
|
|
gfc_copy_loopinfo_to_se (&rse, &loop2);
|
|
|
|
gfc_mark_ss_chain_used (lss, 1);
|
|
gfc_mark_ss_chain_used (loop.temp_ss, 1);
|
|
|
|
/* Declare the variable to hold the temporary offset and start the
|
|
scalarized loop body. */
|
|
offset = gfc_create_var (gfc_array_index_type, NULL);
|
|
gfc_start_scalarized_body (&loop2, &body);
|
|
|
|
/* Build the offsets for the temporary from the loop variables. The
|
|
temporary array has lbounds of zero and strides of one in all
|
|
dimensions, so this is very simple. The offset is only computed
|
|
outside the innermost loop, so the overall transfer could be
|
|
optimized further. */
|
|
info = &rse.ss->info->data.array;
|
|
|
|
tmp_index = gfc_index_zero_node;
|
|
for (n = dimen - 1; n > 0; n--)
|
|
{
|
|
tree tmp_str;
|
|
tmp = rse.loop->loopvar[n];
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
tmp, rse.loop->from[n]);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
|
tmp, tmp_index);
|
|
|
|
tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
rse.loop->to[n-1], rse.loop->from[n-1]);
|
|
tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type,
|
|
tmp_str, gfc_index_one_node);
|
|
|
|
tmp_index = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, tmp, tmp_str);
|
|
}
|
|
|
|
tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
tmp_index, rse.loop->from[0]);
|
|
gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
|
|
|
|
tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type,
|
|
rse.loop->loopvar[0], offset);
|
|
|
|
/* Now use the offset for the reference. */
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
info->data);
|
|
rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
|
|
|
|
if (expr->ts.type == BT_CHARACTER)
|
|
rse.string_length = expr->ts.u.cl->backend_decl;
|
|
|
|
gfc_conv_expr (&lse, expr);
|
|
|
|
gcc_assert (lse.ss == gfc_ss_terminator);
|
|
|
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
|
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
|
/* Generate the copying loops. */
|
|
gfc_trans_scalarizing_loops (&loop2, &body);
|
|
|
|
/* Wrap the whole thing up by adding the second loop to the post-block
|
|
and following it by the post-block of the first loop. In this way,
|
|
if the temporary needs freeing, it is done after use! */
|
|
if (intent != INTENT_IN)
|
|
{
|
|
gfc_add_block_to_block (&parmse->post, &loop2.pre);
|
|
gfc_add_block_to_block (&parmse->post, &loop2.post);
|
|
}
|
|
|
|
class_array_fcn:
|
|
|
|
gfc_add_block_to_block (&parmse->post, &loop.post);
|
|
|
|
gfc_cleanup_loop (&loop);
|
|
gfc_cleanup_loop (&loop2);
|
|
|
|
/* Pass the string length to the argument expression. */
|
|
if (expr->ts.type == BT_CHARACTER)
|
|
parmse->string_length = expr->ts.u.cl->backend_decl;
|
|
|
|
/* Determine the offset for pointer formal arguments and set the
|
|
lbounds to one. */
|
|
if (formal_ptr)
|
|
{
|
|
size = gfc_index_one_node;
|
|
offset = gfc_index_zero_node;
|
|
for (n = 0; n < dimen; n++)
|
|
{
|
|
tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
|
|
gfc_rank_cst[n]);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type, tmp,
|
|
gfc_index_one_node);
|
|
gfc_conv_descriptor_ubound_set (&parmse->pre,
|
|
parmse->expr,
|
|
gfc_rank_cst[n],
|
|
tmp);
|
|
gfc_conv_descriptor_lbound_set (&parmse->pre,
|
|
parmse->expr,
|
|
gfc_rank_cst[n],
|
|
gfc_index_one_node);
|
|
size = gfc_evaluate_now (size, &parmse->pre);
|
|
offset = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
offset, size);
|
|
offset = gfc_evaluate_now (offset, &parmse->pre);
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
rse.loop->to[n], rse.loop->from[n]);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type,
|
|
tmp, gfc_index_one_node);
|
|
size = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, size, tmp);
|
|
}
|
|
|
|
gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
|
|
offset);
|
|
}
|
|
|
|
/* We want either the address for the data or the address of the descriptor,
|
|
depending on the mode of passing array arguments. */
|
|
if (g77)
|
|
parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
|
|
else
|
|
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
|
|
|
|
/* Basically make this into
|
|
|
|
if (present)
|
|
{
|
|
if (contiguous)
|
|
{
|
|
pointer = a;
|
|
}
|
|
else
|
|
{
|
|
parmse->pre();
|
|
pointer = parmse->expr;
|
|
}
|
|
}
|
|
else
|
|
pointer = NULL;
|
|
|
|
foo (pointer);
|
|
if (present && !contiguous)
|
|
se->post();
|
|
|
|
*/
|
|
|
|
if (pass_optional || check_contiguous)
|
|
{
|
|
tree type;
|
|
stmtblock_t else_block;
|
|
tree pre_stmts, post_stmts;
|
|
tree pointer;
|
|
tree else_stmt;
|
|
tree present_var = NULL_TREE;
|
|
tree cont_var = NULL_TREE;
|
|
tree post_cond;
|
|
|
|
type = TREE_TYPE (parmse->expr);
|
|
if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
|
|
type = TREE_TYPE (type);
|
|
pointer = gfc_create_var (type, "arg_ptr");
|
|
|
|
if (check_contiguous)
|
|
{
|
|
gfc_se cont_se, array_se;
|
|
stmtblock_t if_block, else_block;
|
|
tree if_stmt, else_stmt;
|
|
mpz_t size;
|
|
bool size_set;
|
|
|
|
cont_var = gfc_create_var (boolean_type_node, "contiguous");
|
|
|
|
/* If the size is known to be one at compile-time, set
|
|
cont_var to true unconditionally. This may look
|
|
inelegant, but we're only doing this during
|
|
optimization, so the statements will be optimized away,
|
|
and this saves complexity here. */
|
|
|
|
size_set = gfc_array_size (expr, &size);
|
|
if (size_set && mpz_cmp_ui (size, 1) == 0)
|
|
{
|
|
gfc_add_modify (&se->pre, cont_var,
|
|
build_one_cst (boolean_type_node));
|
|
}
|
|
else
|
|
{
|
|
/* cont_var = is_contiguous (expr); . */
|
|
gfc_init_se (&cont_se, parmse);
|
|
gfc_conv_is_contiguous_expr (&cont_se, expr);
|
|
gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
|
|
gfc_add_modify (&se->pre, cont_var, cont_se.expr);
|
|
gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
|
|
}
|
|
|
|
if (size_set)
|
|
mpz_clear (size);
|
|
|
|
/* arrayse->expr = descriptor of a. */
|
|
gfc_init_se (&array_se, se);
|
|
gfc_conv_expr_descriptor (&array_se, expr);
|
|
gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
|
|
gfc_add_block_to_block (&se->pre, &(&array_se)->post);
|
|
|
|
/* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
|
|
gfc_init_block (&if_block);
|
|
if (GFC_DESCRIPTOR_TYPE_P (type))
|
|
gfc_add_modify (&if_block, pointer, array_se.expr);
|
|
else
|
|
{
|
|
tmp = gfc_conv_array_data (array_se.expr);
|
|
tmp = fold_convert (type, tmp);
|
|
gfc_add_modify (&if_block, pointer, tmp);
|
|
}
|
|
if_stmt = gfc_finish_block (&if_block);
|
|
|
|
/* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
|
|
gfc_init_block (&else_block);
|
|
gfc_add_block_to_block (&else_block, &parmse->pre);
|
|
tmp = (GFC_DESCRIPTOR_TYPE_P (type)
|
|
? build_fold_indirect_ref_loc (input_location, parmse->expr)
|
|
: parmse->expr);
|
|
gfc_add_modify (&else_block, pointer, tmp);
|
|
else_stmt = gfc_finish_block (&else_block);
|
|
|
|
/* And put the above into an if statement. */
|
|
pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
|
gfc_likely (cont_var,
|
|
PRED_FORTRAN_CONTIGUOUS),
|
|
if_stmt, else_stmt);
|
|
}
|
|
else
|
|
{
|
|
/* pointer = pramse->expr; . */
|
|
gfc_add_modify (&parmse->pre, pointer, parmse->expr);
|
|
pre_stmts = gfc_finish_block (&parmse->pre);
|
|
}
|
|
|
|
if (pass_optional)
|
|
{
|
|
present_var = gfc_create_var (boolean_type_node, "present");
|
|
|
|
/* present_var = present(sym); . */
|
|
tmp = gfc_conv_expr_present (sym);
|
|
tmp = fold_convert (boolean_type_node, tmp);
|
|
gfc_add_modify (&se->pre, present_var, tmp);
|
|
|
|
/* else_stmt = { pointer = NULL; } . */
|
|
gfc_init_block (&else_block);
|
|
if (GFC_DESCRIPTOR_TYPE_P (type))
|
|
gfc_conv_descriptor_data_set (&else_block, pointer,
|
|
null_pointer_node);
|
|
else
|
|
gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
|
|
else_stmt = gfc_finish_block (&else_block);
|
|
|
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
|
gfc_likely (present_var,
|
|
PRED_FORTRAN_ABSENT_DUMMY),
|
|
pre_stmts, else_stmt);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
else
|
|
gfc_add_expr_to_block (&se->pre, pre_stmts);
|
|
|
|
post_stmts = gfc_finish_block (&parmse->post);
|
|
|
|
/* Put together the post stuff, plus the optional
|
|
deallocation. */
|
|
if (check_contiguous)
|
|
{
|
|
/* !cont_var. */
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
|
|
cont_var,
|
|
build_zero_cst (boolean_type_node));
|
|
tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
|
|
|
|
if (pass_optional)
|
|
{
|
|
tree present_likely = gfc_likely (present_var,
|
|
PRED_FORTRAN_ABSENT_DUMMY);
|
|
post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
|
|
boolean_type_node, present_likely,
|
|
tmp);
|
|
}
|
|
else
|
|
post_cond = tmp;
|
|
}
|
|
else
|
|
{
|
|
gcc_assert (pass_optional);
|
|
post_cond = present_var;
|
|
}
|
|
|
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
|
|
post_stmts, build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
if (GFC_DESCRIPTOR_TYPE_P (type))
|
|
{
|
|
type = TREE_TYPE (parmse->expr);
|
|
if (POINTER_TYPE_P (type))
|
|
{
|
|
pointer = gfc_build_addr_expr (type, pointer);
|
|
if (pass_optional)
|
|
{
|
|
tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
|
|
pointer = fold_build3_loc (input_location, COND_EXPR, type,
|
|
tmp, pointer,
|
|
fold_convert (type,
|
|
null_pointer_node));
|
|
}
|
|
}
|
|
else
|
|
gcc_assert (!pass_optional);
|
|
}
|
|
se->expr = pointer;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
/* Generate the code for argument list functions. */
|
|
|
|
static void
|
|
conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
|
|
{
|
|
/* Pass by value for g77 %VAL(arg), pass the address
|
|
indirectly for %LOC, else by reference. Thus %REF
|
|
is a "do-nothing" and %LOC is the same as an F95
|
|
pointer. */
|
|
if (strcmp (name, "%VAL") == 0)
|
|
gfc_conv_expr (se, expr);
|
|
else if (strcmp (name, "%LOC") == 0)
|
|
{
|
|
gfc_conv_expr_reference (se, expr);
|
|
se->expr = gfc_build_addr_expr (NULL, se->expr);
|
|
}
|
|
else if (strcmp (name, "%REF") == 0)
|
|
gfc_conv_expr_reference (se, expr);
|
|
else
|
|
gfc_error ("Unknown argument list function at %L", &expr->where);
|
|
}
|
|
|
|
|
|
/* This function tells whether the middle-end representation of the expression
|
|
E given as input may point to data otherwise accessible through a variable
|
|
(sub-)reference.
|
|
It is assumed that the only expressions that may alias are variables,
|
|
and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
|
|
may alias.
|
|
This function is used to decide whether freeing an expression's allocatable
|
|
components is safe or should be avoided.
|
|
|
|
If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
|
|
its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
|
|
is necessary because for array constructors, aliasing depends on how
|
|
the array is used:
|
|
- If E is an array constructor used as argument to an elemental procedure,
|
|
the array, which is generated through shallow copy by the scalarizer,
|
|
is used directly and can alias the expressions it was copied from.
|
|
- If E is an array constructor used as argument to a non-elemental
|
|
procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
|
|
the array as in the previous case, but then that array is used
|
|
to initialize a new descriptor through deep copy. There is no alias
|
|
possible in that case.
|
|
Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
|
|
above. */
|
|
|
|
static bool
|
|
expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
|
|
{
|
|
gfc_constructor *c;
|
|
|
|
if (e->expr_type == EXPR_VARIABLE)
|
|
return true;
|
|
else if (e->expr_type == EXPR_FUNCTION)
|
|
{
|
|
gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
|
|
|
|
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;
|
|
}
|
|
else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
|
|
return false;
|
|
|
|
for (c = gfc_constructor_first (e->value.constructor);
|
|
c; c = gfc_constructor_next (c))
|
|
if (c->expr
|
|
&& expr_may_alias_variables (c->expr, array_may_alias))
|
|
return true;
|
|
|
|
return false;
|
|
}
|
|
|
|
|
|
/* A helper function to set the dtype for unallocated or unassociated
|
|
entities. */
|
|
|
|
static void
|
|
set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
|
|
{
|
|
tree tmp;
|
|
tree desc;
|
|
tree cond;
|
|
tree type;
|
|
stmtblock_t block;
|
|
|
|
/* TODO Figure out how to handle optional dummies. */
|
|
if (e && e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
return;
|
|
|
|
desc = parmse->expr;
|
|
if (desc == NULL_TREE)
|
|
return;
|
|
|
|
if (POINTER_TYPE_P (TREE_TYPE (desc)))
|
|
desc = build_fold_indirect_ref_loc (input_location, desc);
|
|
if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
|
|
desc = gfc_class_data_get (desc);
|
|
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
|
|
return;
|
|
|
|
gfc_init_block (&block);
|
|
tmp = gfc_conv_descriptor_data_get (desc);
|
|
cond = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_type_node, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), 0));
|
|
tmp = gfc_conv_descriptor_dtype (desc);
|
|
type = gfc_get_element_type (TREE_TYPE (desc));
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
|
|
TREE_TYPE (tmp), tmp,
|
|
gfc_get_dtype_rank_type (e->rank, type));
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
cond = build3_v (COND_EXPR, cond,
|
|
gfc_finish_block (&block),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&parmse->pre, cond);
|
|
}
|
|
|
|
|
|
|
|
/* Provide an interface between gfortran array descriptors and the F2018:18.4
|
|
ISO_Fortran_binding array descriptors. */
|
|
|
|
static void
|
|
gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
|
|
{
|
|
stmtblock_t block, block2;
|
|
tree cfi, gfc, tmp, tmp2;
|
|
tree present = NULL;
|
|
tree gfc_strlen = NULL;
|
|
tree rank;
|
|
gfc_se se;
|
|
|
|
if (fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
present = gfc_conv_expr_present (e->symtree->n.sym);
|
|
|
|
gfc_init_block (&block);
|
|
|
|
/* Convert original argument to a tree. */
|
|
gfc_init_se (&se, NULL);
|
|
if (e->rank == 0)
|
|
{
|
|
se.want_pointer = 1;
|
|
gfc_conv_expr (&se, e);
|
|
gfc = se.expr;
|
|
/* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
|
|
if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
|
|
gfc = gfc_build_addr_expr (NULL, gfc);
|
|
}
|
|
else
|
|
{
|
|
/* If the actual argument can be noncontiguous, copy-in/out is required,
|
|
if the dummy has either the CONTIGUOUS attribute or is an assumed-
|
|
length assumed-length/assumed-size CHARACTER array. This only
|
|
applies if the actual argument is a "variable"; if it's some
|
|
non-lvalue expression, we are going to evaluate it to a
|
|
temporary below anyway. */
|
|
se.force_no_tmp = 1;
|
|
if ((fsym->attr.contiguous
|
|
|| (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
|
|
&& (fsym->as->type == AS_ASSUMED_SIZE
|
|
|| fsym->as->type == AS_EXPLICIT)))
|
|
&& !gfc_is_simply_contiguous (e, false, true)
|
|
&& gfc_expr_is_variable (e))
|
|
{
|
|
bool optional = fsym->attr.optional;
|
|
fsym->attr.optional = 0;
|
|
gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
|
|
fsym->attr.pointer, fsym,
|
|
fsym->ns->proc_name->name, NULL,
|
|
/* check_contiguous= */ true);
|
|
fsym->attr.optional = optional;
|
|
}
|
|
else
|
|
gfc_conv_expr_descriptor (&se, e);
|
|
gfc = se.expr;
|
|
/* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
|
|
elem_len = sizeof(dt) and base_addr = dt(lb) instead.
|
|
gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
|
|
While sm is fine as it uses span*stride and not elem_len. */
|
|
if (POINTER_TYPE_P (TREE_TYPE (gfc)))
|
|
gfc = build_fold_indirect_ref_loc (input_location, gfc);
|
|
else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
|
|
gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
|
|
}
|
|
if (e->ts.type == BT_CHARACTER)
|
|
{
|
|
if (se.string_length)
|
|
gfc_strlen = se.string_length;
|
|
else if (e->ts.u.cl->backend_decl)
|
|
gfc_strlen = e->ts.u.cl->backend_decl;
|
|
else
|
|
gcc_unreachable ();
|
|
}
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
|
/* Create array decriptor and set version, rank, attribute, type. */
|
|
cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
|
|
? GFC_MAX_DIMENSIONS : e->rank,
|
|
false), "cfi");
|
|
/* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
|
|
if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
|
|
{
|
|
tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
|
|
tmp = build_pointer_type (tmp);
|
|
parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
|
|
cfi = build_fold_indirect_ref_loc (input_location, cfi);
|
|
}
|
|
else
|
|
parmse->expr = gfc_build_addr_expr (NULL, cfi);
|
|
|
|
tmp = gfc_get_cfi_desc_version (cfi);
|
|
gfc_add_modify (&block, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
|
|
if (e->rank < 0)
|
|
rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
|
|
else
|
|
rank = build_int_cst (signed_char_type_node, e->rank);
|
|
tmp = gfc_get_cfi_desc_rank (cfi);
|
|
gfc_add_modify (&block, tmp, rank);
|
|
int itype = CFI_type_other;
|
|
if (e->ts.f90_type == BT_VOID)
|
|
itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
|
|
? CFI_type_cfunptr : CFI_type_cptr);
|
|
else
|
|
{
|
|
if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
|
|
e->ts = fsym->ts;
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
case BT_LOGICAL:
|
|
case BT_REAL:
|
|
case BT_COMPLEX:
|
|
itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
|
|
break;
|
|
case BT_CHARACTER:
|
|
itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
|
|
break;
|
|
case BT_DERIVED:
|
|
itype = CFI_type_struct;
|
|
break;
|
|
case BT_VOID:
|
|
itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
|
|
? CFI_type_cfunptr : CFI_type_cptr);
|
|
break;
|
|
case BT_ASSUMED:
|
|
itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
|
|
break;
|
|
case BT_CLASS:
|
|
if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED)
|
|
{
|
|
// F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
|
|
// type specifier is assumed-type and is an unlimited polymorphic
|
|
// entity." The actual argument _data component is passed.
|
|
itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
|
|
break;
|
|
}
|
|
else
|
|
gcc_unreachable ();
|
|
case BT_PROCEDURE:
|
|
case BT_HOLLERITH:
|
|
case BT_UNION:
|
|
case BT_BOZ:
|
|
case BT_UNKNOWN:
|
|
// FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
|
|
gcc_unreachable ();
|
|
}
|
|
}
|
|
|
|
tmp = gfc_get_cfi_desc_type (cfi);
|
|
gfc_add_modify (&block, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), itype));
|
|
|
|
int attr = CFI_attribute_other;
|
|
if (fsym->attr.pointer)
|
|
attr = CFI_attribute_pointer;
|
|
else if (fsym->attr.allocatable)
|
|
attr = CFI_attribute_allocatable;
|
|
tmp = gfc_get_cfi_desc_attribute (cfi);
|
|
gfc_add_modify (&block, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), attr));
|
|
|
|
if (e->rank == 0)
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi);
|
|
gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
|
|
}
|
|
else
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi);
|
|
tmp2 = gfc_conv_descriptor_data_get (gfc);
|
|
gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
|
|
}
|
|
|
|
/* Set elem_len if known - must be before the next if block.
|
|
Note that allocatable implies 'len=:'. */
|
|
if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
|
|
{
|
|
/* Length is known at compile time; use 'block' for it. */
|
|
tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
|
|
tmp2 = gfc_get_cfi_desc_elem_len (cfi);
|
|
gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
|
|
}
|
|
|
|
/* When allocatable + intent out, free the cfi descriptor. */
|
|
if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi);
|
|
tree call = builtin_decl_explicit (BUILT_IN_FREE);
|
|
call = build_call_expr_loc (input_location, call, 1, tmp);
|
|
gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
|
|
gfc_add_modify (&block, tmp,
|
|
fold_convert (TREE_TYPE (tmp), null_pointer_node));
|
|
goto done;
|
|
}
|
|
|
|
/* If not unallocated/unassociated. */
|
|
gfc_init_block (&block2);
|
|
|
|
/* Set elem_len, which may be only known at run time. */
|
|
if (e->ts.type == BT_CHARACTER
|
|
&& (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
|
|
{
|
|
gcc_assert (gfc_strlen);
|
|
tmp = gfc_strlen;
|
|
if (e->ts.kind != 1)
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_charlen_type_node, tmp,
|
|
build_int_cst (gfc_charlen_type_node,
|
|
e->ts.kind));
|
|
tmp2 = gfc_get_cfi_desc_elem_len (cfi);
|
|
gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
|
|
}
|
|
else if (e->ts.type == BT_ASSUMED)
|
|
{
|
|
tmp = gfc_conv_descriptor_elem_len (gfc);
|
|
tmp2 = gfc_get_cfi_desc_elem_len (cfi);
|
|
gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
|
|
}
|
|
|
|
if (e->ts.type == BT_ASSUMED)
|
|
{
|
|
/* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
|
|
an CFI descriptor. Use the type in the descritor as it provide
|
|
mode information. (Quality of implementation feature.) */
|
|
tree cond;
|
|
tree ctype = gfc_get_cfi_desc_type (cfi);
|
|
tree type = fold_convert (TREE_TYPE (ctype),
|
|
gfc_conv_descriptor_type (gfc));
|
|
tree kind = fold_convert (TREE_TYPE (ctype),
|
|
gfc_conv_descriptor_elem_len (gfc));
|
|
kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
|
|
kind, build_int_cst (TREE_TYPE (type),
|
|
CFI_type_kind_shift));
|
|
|
|
/* if (BT_VOID) CFI_type_cptr else CFI_type_other */
|
|
/* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_VOID));
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
|
|
build_int_cst (TREE_TYPE (type), CFI_type_cptr));
|
|
tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
|
ctype,
|
|
build_int_cst (TREE_TYPE (type), CFI_type_other));
|
|
tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
|
tmp, tmp2);
|
|
/* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_DERIVED));
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
|
|
build_int_cst (TREE_TYPE (type), CFI_type_struct));
|
|
tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
|
tmp, tmp2);
|
|
/* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
|
|
/* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_CHARACTER));
|
|
tmp = build_int_cst (TREE_TYPE (type),
|
|
CFI_type_from_type_kind (CFI_type_Character, 1));
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
|
ctype, tmp);
|
|
tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
|
tmp, tmp2);
|
|
/* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_COMPLEX));
|
|
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
|
|
kind, build_int_cst (TREE_TYPE (type), 2));
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
|
|
build_int_cst (TREE_TYPE (type),
|
|
CFI_type_Complex));
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
|
ctype, tmp);
|
|
tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
|
tmp, tmp2);
|
|
/* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_INTEGER));
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_LOGICAL));
|
|
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
|
|
cond, tmp);
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
|
|
build_int_cst (TREE_TYPE (type), BT_REAL));
|
|
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
|
|
cond, tmp);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
|
|
type, kind);
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
|
ctype, tmp);
|
|
tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
|
tmp, tmp2);
|
|
gfc_add_expr_to_block (&block2, tmp2);
|
|
}
|
|
|
|
if (e->rank != 0)
|
|
{
|
|
/* Loop: for (i = 0; i < rank; ++i). */
|
|
tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
|
|
/* Loop body. */
|
|
stmtblock_t loop_body;
|
|
gfc_init_block (&loop_body);
|
|
/* cfi->dim[i].lower_bound = (allocatable/pointer)
|
|
? gfc->dim[i].lbound : 0 */
|
|
if (fsym->attr.pointer || fsym->attr.allocatable)
|
|
tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
|
|
else
|
|
tmp = gfc_index_zero_node;
|
|
gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
|
|
/* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_ubound_get (gfc, idx),
|
|
gfc_conv_descriptor_lbound_get (gfc, idx));
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
|
tmp, gfc_index_one_node);
|
|
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
|
|
/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_stride_get (gfc, idx),
|
|
gfc_conv_descriptor_span_get (gfc));
|
|
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
|
|
|
|
/* Generate loop. */
|
|
gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
|
|
rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
|
|
gfc_finish_block (&loop_body));
|
|
|
|
if (e->expr_type == EXPR_VARIABLE
|
|
&& e->ref
|
|
&& e->ref->u.ar.type == AR_FULL
|
|
&& e->symtree->n.sym->attr.dummy
|
|
&& e->symtree->n.sym->as
|
|
&& e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
|
|
{
|
|
tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
|
|
gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
|
|
}
|
|
}
|
|
|
|
if (fsym->attr.allocatable || fsym->attr.pointer)
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi),
|
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
|
tmp, null_pointer_node);
|
|
tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
else
|
|
gfc_add_block_to_block (&block, &block2);
|
|
|
|
|
|
done:
|
|
if (present)
|
|
{
|
|
parmse->expr = build3_loc (input_location, COND_EXPR,
|
|
TREE_TYPE (parmse->expr),
|
|
present, parmse->expr, null_pointer_node);
|
|
tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&parmse->pre, tmp);
|
|
}
|
|
else
|
|
gfc_add_block_to_block (&parmse->pre, &block);
|
|
|
|
gfc_init_block (&block);
|
|
|
|
if ((!fsym->attr.allocatable && !fsym->attr.pointer)
|
|
|| fsym->attr.intent == INTENT_IN)
|
|
goto post_call;
|
|
|
|
gfc_init_block (&block2);
|
|
if (e->rank == 0)
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi);
|
|
gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
|
|
}
|
|
else
|
|
{
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi);
|
|
gfc_conv_descriptor_data_set (&block, gfc, tmp);
|
|
|
|
if (fsym->attr.allocatable)
|
|
{
|
|
/* gfc->span = cfi->elem_len. */
|
|
tmp = fold_convert (gfc_array_index_type,
|
|
gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
|
|
}
|
|
else
|
|
{
|
|
/* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
|
|
? cfi->dim[0].sm : cfi->elem_len). */
|
|
tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
|
|
tmp2 = fold_convert (gfc_array_index_type,
|
|
gfc_get_cfi_desc_elem_len (cfi));
|
|
tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
|
|
gfc_array_index_type, tmp, tmp2);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
|
tmp, gfc_index_zero_node);
|
|
tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
|
|
gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
|
|
}
|
|
gfc_conv_descriptor_span_set (&block2, gfc, tmp);
|
|
|
|
/* Calculate offset + set lbound, ubound and stride. */
|
|
gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
|
|
/* Loop: for (i = 0; i < rank; ++i). */
|
|
tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
|
|
/* Loop body. */
|
|
stmtblock_t loop_body;
|
|
gfc_init_block (&loop_body);
|
|
/* gfc->dim[i].lbound = ... */
|
|
tmp = gfc_get_cfi_dim_lbound (cfi, idx);
|
|
gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
|
|
|
|
/* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_lbound_get (gfc, idx),
|
|
gfc_index_one_node);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
|
gfc_get_cfi_dim_extent (cfi, idx), tmp);
|
|
gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
|
|
|
|
/* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
|
|
tmp = gfc_get_cfi_dim_sm (cfi, idx);
|
|
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
|
gfc_array_index_type, tmp,
|
|
fold_convert (gfc_array_index_type,
|
|
gfc_get_cfi_desc_elem_len (cfi)));
|
|
gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
|
|
|
|
/* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_stride_get (gfc, idx),
|
|
gfc_conv_descriptor_lbound_get (gfc, idx));
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_offset_get (gfc), tmp);
|
|
gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
|
|
/* Generate loop. */
|
|
gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
|
|
rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
|
|
gfc_finish_block (&loop_body));
|
|
}
|
|
|
|
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
|
|
{
|
|
tmp = fold_convert (gfc_charlen_type_node,
|
|
gfc_get_cfi_desc_elem_len (cfi));
|
|
if (e->ts.kind != 1)
|
|
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
|
gfc_charlen_type_node, tmp,
|
|
build_int_cst (gfc_charlen_type_node,
|
|
e->ts.kind));
|
|
gfc_add_modify (&block2, gfc_strlen, tmp);
|
|
}
|
|
|
|
tmp = gfc_get_cfi_desc_base_addr (cfi),
|
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
|
tmp, null_pointer_node);
|
|
tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
|
post_call:
|
|
gfc_add_block_to_block (&block, &se.post);
|
|
if (present && block.head)
|
|
{
|
|
tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&parmse->post, tmp);
|
|
}
|
|
else if (block.head)
|
|
gfc_add_block_to_block (&parmse->post, &block);
|
|
}
|
|
|
|
|
|
/* Generate code for a procedure call. Note can return se->post != NULL.
|
|
If se->direct_byref is set then se->expr contains the return parameter.
|
|
Return nonzero, if the call has alternate specifiers.
|
|
'expr' is only needed for procedure pointer components. */
|
|
|
|
int
|
|
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|
|
gfc_actual_arglist * args, gfc_expr * expr,
|
|
vec<tree, va_gc> *append_args)
|
|
{
|
|
gfc_interface_mapping mapping;
|
|
vec<tree, va_gc> *arglist;
|
|
vec<tree, va_gc> *retargs;
|
|
tree tmp;
|
|
tree fntype;
|
|
gfc_se parmse;
|
|
gfc_array_info *info;
|
|
int byref;
|
|
int parm_kind;
|
|
tree type;
|
|
tree var;
|
|
tree len;
|
|
tree base_object;
|
|
vec<tree, va_gc> *stringargs;
|
|
vec<tree, va_gc> *optionalargs;
|
|
tree result = NULL;
|
|
gfc_formal_arglist *formal;
|
|
gfc_actual_arglist *arg;
|
|
int has_alternate_specifier = 0;
|
|
bool need_interface_mapping;
|
|
bool callee_alloc;
|
|
bool ulim_copy;
|
|
gfc_typespec ts;
|
|
gfc_charlen cl;
|
|
gfc_expr *e;
|
|
gfc_symbol *fsym;
|
|
stmtblock_t post;
|
|
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
|
|
gfc_component *comp = NULL;
|
|
int arglen;
|
|
unsigned int argc;
|
|
|
|
arglist = NULL;
|
|
retargs = NULL;
|
|
stringargs = NULL;
|
|
optionalargs = NULL;
|
|
var = NULL_TREE;
|
|
len = NULL_TREE;
|
|
gfc_clear_ts (&ts);
|
|
|
|
comp = gfc_get_proc_ptr_comp (expr);
|
|
|
|
bool elemental_proc = (comp
|
|
&& comp->ts.interface
|
|
&& comp->ts.interface->attr.elemental)
|
|
|| (comp && comp->attr.elemental)
|
|
|| sym->attr.elemental;
|
|
|
|
if (se->ss != NULL)
|
|
{
|
|
if (!elemental_proc)
|
|
{
|
|
gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
|
|
if (se->ss->info->useflags)
|
|
{
|
|
gcc_assert ((!comp && gfc_return_by_reference (sym)
|
|
&& sym->result->attr.dimension)
|
|
|| (comp && comp->attr.dimension)
|
|
|| gfc_is_class_array_function (expr));
|
|
gcc_assert (se->loop != NULL);
|
|
/* Access the previously obtained result. */
|
|
gfc_conv_tmp_array_ref (se);
|
|
return 0;
|
|
}
|
|
}
|
|
info = &se->ss->info->data.array;
|
|
}
|
|
else
|
|
info = NULL;
|
|
|
|
gfc_init_block (&post);
|
|
gfc_init_interface_mapping (&mapping);
|
|
if (!comp)
|
|
{
|
|
formal = gfc_sym_get_dummy_args (sym);
|
|
need_interface_mapping = sym->attr.dimension ||
|
|
(sym->ts.type == BT_CHARACTER
|
|
&& sym->ts.u.cl->length
|
|
&& sym->ts.u.cl->length->expr_type
|
|
!= EXPR_CONSTANT);
|
|
}
|
|
else
|
|
{
|
|
formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
|
|
need_interface_mapping = comp->attr.dimension ||
|
|
(comp->ts.type == BT_CHARACTER
|
|
&& comp->ts.u.cl->length
|
|
&& comp->ts.u.cl->length->expr_type
|
|
!= EXPR_CONSTANT);
|
|
}
|
|
|
|
base_object = NULL_TREE;
|
|
/* For _vprt->_copy () routines no formal symbol is present. Nevertheless
|
|
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)
|
|
&& comp && (strcmp ("_copy", comp->name) == 0);
|
|
|
|
/* Evaluate the arguments. */
|
|
for (arg = args, argc = 0; arg != NULL;
|
|
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
|
|
{
|
|
bool finalized = false;
|
|
tree derived_array = NULL_TREE;
|
|
|
|
e = arg->expr;
|
|
fsym = formal ? formal->sym : NULL;
|
|
parm_kind = MISSING;
|
|
|
|
/* If the procedure requires an explicit interface, the actual
|
|
argument is passed according to the corresponding formal
|
|
argument. If the corresponding formal argument is a POINTER,
|
|
ALLOCATABLE or assumed shape, we do not use g77's calling
|
|
convention, and pass the address of the array descriptor
|
|
instead. Otherwise we use g77's calling convention, in other words
|
|
pass the array data pointer without descriptor. */
|
|
bool nodesc_arg = fsym != NULL
|
|
&& !(fsym->attr.pointer || fsym->attr.allocatable)
|
|
&& fsym->as
|
|
&& fsym->as->type != AS_ASSUMED_SHAPE
|
|
&& fsym->as->type != AS_ASSUMED_RANK;
|
|
if (comp)
|
|
nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
|
|
else
|
|
nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
|
|
|
|
/* Class array expressions are sometimes coming completely unadorned
|
|
with either arrayspec or _data component. Correct that here.
|
|
OOP-TODO: Move this to the frontend. */
|
|
if (e && e->expr_type == EXPR_VARIABLE
|
|
&& !e->ref
|
|
&& e->ts.type == BT_CLASS
|
|
&& (CLASS_DATA (e)->attr.codimension
|
|
|| CLASS_DATA (e)->attr.dimension))
|
|
{
|
|
gfc_typespec temp_ts = e->ts;
|
|
gfc_add_class_array_ref (e);
|
|
e->ts = temp_ts;
|
|
}
|
|
|
|
if (e == NULL)
|
|
{
|
|
if (se->ignore_optional)
|
|
{
|
|
/* Some intrinsics have already been resolved to the correct
|
|
parameters. */
|
|
continue;
|
|
}
|
|
else if (arg->label)
|
|
{
|
|
has_alternate_specifier = 1;
|
|
continue;
|
|
}
|
|
else
|
|
{
|
|
gfc_init_se (&parmse, NULL);
|
|
|
|
/* For scalar arguments with VALUE attribute which are passed by
|
|
value, pass "0" and a hidden argument gives the optional
|
|
status. */
|
|
if (fsym && fsym->attr.optional && fsym->attr.value
|
|
&& !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
|
|
&& fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
|
|
{
|
|
parmse.expr = fold_convert (gfc_sym_type (fsym),
|
|
integer_zero_node);
|
|
vec_safe_push (optionalargs, boolean_false_node);
|
|
}
|
|
else
|
|
{
|
|
/* Pass a NULL pointer for an absent arg. */
|
|
parmse.expr = null_pointer_node;
|
|
gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
|
|
if (dummy_arg
|
|
&& gfc_dummy_arg_get_typespec (*dummy_arg).type
|
|
== BT_CHARACTER)
|
|
parmse.string_length = build_int_cst (gfc_charlen_type_node,
|
|
0);
|
|
}
|
|
}
|
|
}
|
|
else if (arg->expr->expr_type == EXPR_NULL
|
|
&& fsym && !fsym->attr.pointer
|
|
&& (fsym->ts.type != BT_CLASS
|
|
|| !CLASS_DATA (fsym)->attr.class_pointer))
|
|
{
|
|
/* Pass a NULL pointer to denote an absent arg. */
|
|
gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
|
|
&& (fsym->ts.type != BT_CLASS
|
|
|| !CLASS_DATA (fsym)->attr.allocatable));
|
|
gfc_init_se (&parmse, NULL);
|
|
parmse.expr = null_pointer_node;
|
|
if (arg->associated_dummy
|
|
&& gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
|
|
== BT_CHARACTER)
|
|
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
|
|
}
|
|
else if (fsym && fsym->ts.type == BT_CLASS
|
|
&& e->ts.type == BT_DERIVED)
|
|
{
|
|
/* The derived type needs to be converted to a temporary
|
|
CLASS object. */
|
|
gfc_init_se (&parmse, se);
|
|
gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
|
|
fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional,
|
|
CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable,
|
|
&derived_array);
|
|
}
|
|
else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
|
|
&& e->ts.type != BT_PROCEDURE
|
|
&& (gfc_expr_attr (e).flavor != FL_PROCEDURE
|
|
|| gfc_expr_attr (e).proc != PROC_UNKNOWN))
|
|
{
|
|
/* The intrinsic type needs to be converted to a temporary
|
|
CLASS object for the unlimited polymorphic formal. */
|
|
gfc_find_vtab (&e->ts);
|
|
gfc_init_se (&parmse, se);
|
|
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
|
|
|
|
}
|
|
else if (se->ss && se->ss->info->useflags)
|
|
{
|
|
gfc_ss *ss;
|
|
|
|
ss = se->ss;
|
|
|
|
/* An elemental function inside a scalarized loop. */
|
|
gfc_init_se (&parmse, se);
|
|
parm_kind = ELEMENTAL;
|
|
|
|
/* When no fsym is present, ulim_copy is set and this is a third or
|
|
fourth argument, use call-by-value instead of by reference to
|
|
hand the length properties to the copy routine (i.e., most of the
|
|
time this will be a call to a __copy_character_* routine where the
|
|
third and fourth arguments are the lengths of a deferred length
|
|
char array). */
|
|
if ((fsym && fsym->attr.value)
|
|
|| (ulim_copy && (argc == 2 || argc == 3)))
|
|
gfc_conv_expr (&parmse, e);
|
|
else
|
|
gfc_conv_expr_reference (&parmse, e);
|
|
|
|
if (e->ts.type == BT_CHARACTER && !e->rank
|
|
&& e->expr_type == EXPR_FUNCTION)
|
|
parmse.expr = build_fold_indirect_ref_loc (input_location,
|
|
parmse.expr);
|
|
|
|
if (fsym && fsym->ts.type == BT_DERIVED
|
|
&& gfc_is_class_container_ref (e))
|
|
{
|
|
parmse.expr = gfc_class_data_get (parmse.expr);
|
|
|
|
if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
{
|
|
tree cond = gfc_conv_expr_present (e->symtree->n.sym);
|
|
parmse.expr = build3_loc (input_location, COND_EXPR,
|
|
TREE_TYPE (parmse.expr),
|
|
cond, parmse.expr,
|
|
fold_convert (TREE_TYPE (parmse.expr),
|
|
null_pointer_node));
|
|
}
|
|
}
|
|
|
|
/* If we are passing an absent array as optional dummy to an
|
|
elemental procedure, make sure that we pass NULL when the data
|
|
pointer is NULL. We need this extra conditional because of
|
|
scalarization which passes arrays elements to the procedure,
|
|
ignoring the fact that the array can be absent/unallocated/... */
|
|
if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
|
|
{
|
|
tree descriptor_data;
|
|
|
|
descriptor_data = ss->info->data.array.data;
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
|
|
descriptor_data,
|
|
fold_convert (TREE_TYPE (descriptor_data),
|
|
null_pointer_node));
|
|
parmse.expr
|
|
= fold_build3_loc (input_location, COND_EXPR,
|
|
TREE_TYPE (parmse.expr),
|
|
gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
|
|
fold_convert (TREE_TYPE (parmse.expr),
|
|
null_pointer_node),
|
|
parmse.expr);
|
|
}
|
|
|
|
/* The scalarizer does not repackage the reference to a class
|
|
array - instead it returns a pointer to the data element. */
|
|
if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
|
|
gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
|
|
fsym->attr.intent != INTENT_IN
|
|
&& (CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable),
|
|
fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional,
|
|
CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable);
|
|
}
|
|
else
|
|
{
|
|
bool scalar;
|
|
gfc_ss *argss;
|
|
|
|
gfc_init_se (&parmse, NULL);
|
|
|
|
/* Check whether the expression is a scalar or not; we cannot use
|
|
e->rank as it can be nonzero for functions arguments. */
|
|
argss = gfc_walk_expr (e);
|
|
scalar = argss == gfc_ss_terminator;
|
|
if (!scalar)
|
|
gfc_free_ss_chain (argss);
|
|
|
|
/* Special handling for passing scalar polymorphic coarrays;
|
|
otherwise one passes "class->_data.data" instead of "&class". */
|
|
if (e->rank == 0 && e->ts.type == BT_CLASS
|
|
&& fsym && fsym->ts.type == BT_CLASS
|
|
&& CLASS_DATA (fsym)->attr.codimension
|
|
&& !CLASS_DATA (fsym)->attr.dimension)
|
|
{
|
|
gfc_add_class_array_ref (e);
|
|
parmse.want_coarray = 1;
|
|
scalar = false;
|
|
}
|
|
|
|
/* A scalar or transformational function. */
|
|
if (scalar)
|
|
{
|
|
if (e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.cray_pointee
|
|
&& fsym && fsym->attr.flavor == FL_PROCEDURE)
|
|
{
|
|
/* The Cray pointer needs to be converted to a pointer to
|
|
a type given by the expression. */
|
|
gfc_conv_expr (&parmse, e);
|
|
type = build_pointer_type (TREE_TYPE (parmse.expr));
|
|
tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
|
|
parmse.expr = convert (type, tmp);
|
|
}
|
|
|
|
else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
|
|
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
|
|
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
|
|
|
|
else if (fsym && fsym->attr.value)
|
|
{
|
|
if (fsym->ts.type == BT_CHARACTER
|
|
&& fsym->ts.is_c_interop
|
|
&& fsym->ns->proc_name != NULL
|
|
&& fsym->ns->proc_name->attr.is_bind_c)
|
|
{
|
|
parmse.expr = NULL;
|
|
conv_scalar_char_value (fsym, &parmse, &e);
|
|
if (parmse.expr == NULL)
|
|
gfc_conv_expr (&parmse, e);
|
|
}
|
|
else
|
|
{
|
|
gfc_conv_expr (&parmse, e);
|
|
if (fsym->attr.optional
|
|
&& fsym->ts.type != BT_CLASS
|
|
&& fsym->ts.type != BT_DERIVED)
|
|
{
|
|
if (e->expr_type != EXPR_VARIABLE
|
|
|| !e->symtree->n.sym->attr.optional
|
|
|| e->ref != NULL)
|
|
vec_safe_push (optionalargs, boolean_true_node);
|
|
else
|
|
{
|
|
tmp = gfc_conv_expr_present (e->symtree->n.sym);
|
|
if (!e->symtree->n.sym->attr.value)
|
|
parmse.expr
|
|
= fold_build3_loc (input_location, COND_EXPR,
|
|
TREE_TYPE (parmse.expr),
|
|
tmp, parmse.expr,
|
|
fold_convert (TREE_TYPE (parmse.expr),
|
|
integer_zero_node));
|
|
|
|
vec_safe_push (optionalargs,
|
|
fold_convert (boolean_type_node,
|
|
tmp));
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
else if (arg->name && arg->name[0] == '%')
|
|
/* Argument list functions %VAL, %LOC and %REF are signalled
|
|
through arg->name. */
|
|
conv_arglist_function (&parmse, arg->expr, arg->name);
|
|
else if ((e->expr_type == EXPR_FUNCTION)
|
|
&& ((e->value.function.esym
|
|
&& e->value.function.esym->result->attr.pointer)
|
|
|| (!e->value.function.esym
|
|
&& e->symtree->n.sym->attr.pointer))
|
|
&& fsym && fsym->attr.target)
|
|
/* Make sure the function only gets called once. */
|
|
gfc_conv_expr_reference (&parmse, e, false);
|
|
else if (e->expr_type == EXPR_FUNCTION
|
|
&& e->symtree->n.sym->result
|
|
&& e->symtree->n.sym->result != e->symtree->n.sym
|
|
&& e->symtree->n.sym->result->attr.proc_pointer)
|
|
{
|
|
/* Functions returning procedure pointers. */
|
|
gfc_conv_expr (&parmse, e);
|
|
if (fsym && fsym->attr.proc_pointer)
|
|
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
|
|
}
|
|
|
|
else
|
|
{
|
|
if (e->ts.type == BT_CLASS && fsym
|
|
&& fsym->ts.type == BT_CLASS
|
|
&& (!CLASS_DATA (fsym)->as
|
|
|| CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
|
|
&& CLASS_DATA (e)->attr.codimension)
|
|
{
|
|
gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
|
|
gcc_assert (!CLASS_DATA (fsym)->as);
|
|
gfc_add_class_array_ref (e);
|
|
parmse.want_coarray = 1;
|
|
gfc_conv_expr_reference (&parmse, e);
|
|
class_scalar_coarray_to_class (&parmse, e, fsym->ts,
|
|
fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE);
|
|
}
|
|
else if (e->ts.type == BT_CLASS && fsym
|
|
&& fsym->ts.type == BT_CLASS
|
|
&& !CLASS_DATA (fsym)->as
|
|
&& !CLASS_DATA (e)->as
|
|
&& strcmp (fsym->ts.u.derived->name,
|
|
e->ts.u.derived->name))
|
|
{
|
|
type = gfc_typenode_for_spec (&fsym->ts);
|
|
var = gfc_create_var (type, fsym->name);
|
|
gfc_conv_expr (&parmse, e);
|
|
if (fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
{
|
|
stmtblock_t block;
|
|
tree cond;
|
|
tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
|
|
cond = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node, tmp,
|
|
fold_convert (TREE_TYPE (tmp),
|
|
null_pointer_node));
|
|
gfc_start_block (&block);
|
|
gfc_add_modify (&block, var,
|
|
fold_build1_loc (input_location,
|
|
VIEW_CONVERT_EXPR,
|
|
type, parmse.expr));
|
|
gfc_add_expr_to_block (&parmse.pre,
|
|
fold_build3_loc (input_location,
|
|
COND_EXPR, void_type_node,
|
|
cond, gfc_finish_block (&block),
|
|
build_empty_stmt (input_location)));
|
|
parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
|
|
parmse.expr = build3_loc (input_location, COND_EXPR,
|
|
TREE_TYPE (parmse.expr),
|
|
cond, parmse.expr,
|
|
fold_convert (TREE_TYPE (parmse.expr),
|
|
null_pointer_node));
|
|
}
|
|
else
|
|
{
|
|
/* Since the internal representation of unlimited
|
|
polymorphic expressions includes an extra field
|
|
that other class objects do not, a cast to the
|
|
formal type does not work. */
|
|
if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
|
|
{
|
|
tree efield;
|
|
|
|
/* Set the _data field. */
|
|
tmp = gfc_class_data_get (var);
|
|
efield = fold_convert (TREE_TYPE (tmp),
|
|
gfc_class_data_get (parmse.expr));
|
|
gfc_add_modify (&parmse.pre, tmp, efield);
|
|
|
|
/* Set the _vptr field. */
|
|
tmp = gfc_class_vptr_get (var);
|
|
efield = fold_convert (TREE_TYPE (tmp),
|
|
gfc_class_vptr_get (parmse.expr));
|
|
gfc_add_modify (&parmse.pre, tmp, efield);
|
|
|
|
/* Set the _len field. */
|
|
tmp = gfc_class_len_get (var);
|
|
gfc_add_modify (&parmse.pre, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), 0));
|
|
}
|
|
else
|
|
{
|
|
tmp = fold_build1_loc (input_location,
|
|
VIEW_CONVERT_EXPR,
|
|
type, parmse.expr);
|
|
gfc_add_modify (&parmse.pre, var, tmp);
|
|
;
|
|
}
|
|
parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
bool add_clobber;
|
|
add_clobber = fsym && fsym->attr.intent == INTENT_OUT
|
|
&& !fsym->attr.allocatable && !fsym->attr.pointer
|
|
&& e->symtree && e->symtree->n.sym
|
|
&& !e->symtree->n.sym->attr.dimension
|
|
&& !e->symtree->n.sym->attr.pointer
|
|
&& !e->symtree->n.sym->attr.allocatable
|
|
/* See PR 41453. */
|
|
&& !e->symtree->n.sym->attr.dummy
|
|
/* FIXME - PR 87395 and PR 41453 */
|
|
&& e->symtree->n.sym->attr.save == SAVE_NONE
|
|
&& !e->symtree->n.sym->attr.associate_var
|
|
&& e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
|
|
&& e->ts.type != BT_CLASS && !sym->attr.elemental;
|
|
|
|
gfc_conv_expr_reference (&parmse, e, add_clobber);
|
|
}
|
|
/* Catch base objects that are not variables. */
|
|
if (e->ts.type == BT_CLASS
|
|
&& e->expr_type != EXPR_VARIABLE
|
|
&& expr && e == expr->base_expr)
|
|
base_object = build_fold_indirect_ref_loc (input_location,
|
|
parmse.expr);
|
|
|
|
/* A class array element needs converting back to be a
|
|
class object, if the formal argument is a class object. */
|
|
if (fsym && fsym->ts.type == BT_CLASS
|
|
&& e->ts.type == BT_CLASS
|
|
&& ((CLASS_DATA (fsym)->as
|
|
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|
|
|| CLASS_DATA (e)->attr.dimension))
|
|
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
|
|
fsym->attr.intent != INTENT_IN
|
|
&& (CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable),
|
|
fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional,
|
|
CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable);
|
|
|
|
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
|
|
allocated on entry, it must be deallocated. */
|
|
if (fsym && fsym->attr.intent == INTENT_OUT
|
|
&& (fsym->attr.allocatable
|
|
|| (fsym->ts.type == BT_CLASS
|
|
&& CLASS_DATA (fsym)->attr.allocatable))
|
|
&& !is_CFI_desc (fsym, NULL))
|
|
{
|
|
stmtblock_t block;
|
|
tree ptr;
|
|
|
|
gfc_init_block (&block);
|
|
ptr = parmse.expr;
|
|
if (e->ts.type == BT_CLASS)
|
|
ptr = gfc_class_data_get (ptr);
|
|
|
|
tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
|
|
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,
|
|
null_pointer_node);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
|
if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
|
|
{
|
|
gfc_add_modify (&block, ptr,
|
|
fold_convert (TREE_TYPE (ptr),
|
|
null_pointer_node));
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
else if (fsym->ts.type == BT_CLASS)
|
|
{
|
|
gfc_symbol *vtab;
|
|
vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
|
|
tmp = gfc_get_symbol_decl (vtab);
|
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
ptr = gfc_class_vptr_get (parmse.expr);
|
|
gfc_add_modify (&block, ptr,
|
|
fold_convert (TREE_TYPE (ptr), tmp));
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
|
|
if (fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
{
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node,
|
|
gfc_conv_expr_present (e->symtree->n.sym),
|
|
gfc_finish_block (&block),
|
|
build_empty_stmt (input_location));
|
|
}
|
|
else
|
|
tmp = gfc_finish_block (&block);
|
|
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
|
|
if (fsym && (fsym->ts.type == BT_DERIVED
|
|
|| fsym->ts.type == BT_ASSUMED)
|
|
&& e->ts.type == BT_CLASS
|
|
&& !CLASS_DATA (e)->attr.dimension
|
|
&& !CLASS_DATA (e)->attr.codimension)
|
|
{
|
|
parmse.expr = gfc_class_data_get (parmse.expr);
|
|
/* The result is a class temporary, whose _data component
|
|
must be freed to avoid a memory leak. */
|
|
if (e->expr_type == EXPR_FUNCTION
|
|
&& CLASS_DATA (e)->attr.allocatable)
|
|
{
|
|
tree zero;
|
|
|
|
gfc_expr *var;
|
|
|
|
/* Borrow the function symbol to make a call to
|
|
gfc_add_finalizer_call and then restore it. */
|
|
tmp = e->symtree->n.sym->backend_decl;
|
|
e->symtree->n.sym->backend_decl
|
|
= TREE_OPERAND (parmse.expr, 0);
|
|
e->symtree->n.sym->attr.flavor = FL_VARIABLE;
|
|
var = gfc_lval_expr_from_sym (e->symtree->n.sym);
|
|
finalized = gfc_add_finalizer_call (&parmse.post,
|
|
var);
|
|
gfc_free_expr (var);
|
|
e->symtree->n.sym->backend_decl = tmp;
|
|
e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
|
|
|
|
/* Then free the class _data. */
|
|
zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node,
|
|
parmse.expr, zero);
|
|
tmp = build3_v (COND_EXPR, tmp,
|
|
gfc_call_free (parmse.expr),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&parmse.post, tmp);
|
|
gfc_add_modify (&parmse.post, parmse.expr, zero);
|
|
}
|
|
}
|
|
|
|
/* Wrap scalar variable in a descriptor. We need to convert
|
|
the address of a pointer back to the pointer itself before,
|
|
we can assign it to the data field. */
|
|
|
|
if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
|
|
&& fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
|
|
{
|
|
tmp = parmse.expr;
|
|
if (TREE_CODE (tmp) == ADDR_EXPR)
|
|
tmp = TREE_OPERAND (tmp, 0);
|
|
parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
|
|
fsym->attr);
|
|
parmse.expr = gfc_build_addr_expr (NULL_TREE,
|
|
parmse.expr);
|
|
}
|
|
else if (fsym && e->expr_type != EXPR_NULL
|
|
&& ((fsym->attr.pointer
|
|
&& fsym->attr.flavor != FL_PROCEDURE)
|
|
|| (fsym->attr.proc_pointer
|
|
&& !(e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.dummy))
|
|
|| (fsym->attr.proc_pointer
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& gfc_is_proc_ptr_comp (e))
|
|
|| (fsym->attr.allocatable
|
|
&& fsym->attr.flavor != FL_PROCEDURE)))
|
|
{
|
|
/* Scalar pointer dummy args require an extra level of
|
|
indirection. The null pointer already contains
|
|
this level of indirection. */
|
|
parm_kind = SCALAR_POINTER;
|
|
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
|
|
}
|
|
}
|
|
}
|
|
else if (e->ts.type == BT_CLASS
|
|
&& fsym && fsym->ts.type == BT_CLASS
|
|
&& (CLASS_DATA (fsym)->attr.dimension
|
|
|| CLASS_DATA (fsym)->attr.codimension))
|
|
{
|
|
/* Pass a class array. */
|
|
parmse.use_offset = 1;
|
|
gfc_conv_expr_descriptor (&parmse, e);
|
|
|
|
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
|
|
allocated on entry, it must be deallocated. */
|
|
if (fsym->attr.intent == INTENT_OUT
|
|
&& CLASS_DATA (fsym)->attr.allocatable)
|
|
{
|
|
stmtblock_t block;
|
|
tree ptr;
|
|
|
|
gfc_init_block (&block);
|
|
ptr = parmse.expr;
|
|
ptr = gfc_class_data_get (ptr);
|
|
|
|
tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
|
|
NULL_TREE, NULL_TREE,
|
|
NULL_TREE, true, e,
|
|
GFC_CAF_COARRAY_NOCOARRAY);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
|
|
void_type_node, ptr,
|
|
null_pointer_node);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
gfc_reset_vptr (&block, e);
|
|
|
|
if (fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& (!e->ref
|
|
|| (e->ref->type == REF_ARRAY
|
|
&& e->ref->u.ar.type != AR_FULL))
|
|
&& e->symtree->n.sym->attr.optional)
|
|
{
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node,
|
|
gfc_conv_expr_present (e->symtree->n.sym),
|
|
gfc_finish_block (&block),
|
|
build_empty_stmt (input_location));
|
|
}
|
|
else
|
|
tmp = gfc_finish_block (&block);
|
|
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
|
|
/* The conversion does not repackage the reference to a class
|
|
array - _data descriptor. */
|
|
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
|
|
fsym->attr.intent != INTENT_IN
|
|
&& (CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable),
|
|
fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional,
|
|
CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable);
|
|
}
|
|
else
|
|
{
|
|
/* If the argument is a function call that may not create
|
|
a temporary for the result, we have to check that we
|
|
can do it, i.e. that there is no alias between this
|
|
argument and another one. */
|
|
if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
|
|
{
|
|
gfc_expr *iarg;
|
|
sym_intent intent;
|
|
|
|
if (fsym != NULL)
|
|
intent = fsym->attr.intent;
|
|
else
|
|
intent = INTENT_UNKNOWN;
|
|
|
|
if (gfc_check_fncall_dependency (e, intent, sym, args,
|
|
NOT_ELEMENTAL))
|
|
parmse.force_tmp = 1;
|
|
|
|
iarg = e->value.function.actual->expr;
|
|
|
|
/* Temporary needed if aliasing due to host association. */
|
|
if (sym->attr.contained
|
|
&& !sym->attr.pure
|
|
&& !sym->attr.implicit_pure
|
|
&& !sym->attr.use_assoc
|
|
&& iarg->expr_type == EXPR_VARIABLE
|
|
&& sym->ns == iarg->symtree->n.sym->ns)
|
|
parmse.force_tmp = 1;
|
|
|
|
/* Ditto within module. */
|
|
if (sym->attr.use_assoc
|
|
&& !sym->attr.pure
|
|
&& !sym->attr.implicit_pure
|
|
&& iarg->expr_type == EXPR_VARIABLE
|
|
&& sym->module == iarg->symtree->n.sym->module)
|
|
parmse.force_tmp = 1;
|
|
}
|
|
|
|
/* Special case for assumed-rank arrays: when passing an
|
|
argument to a nonallocatable/nonpointer dummy, the bounds have
|
|
to be reset as otherwise a last-dim ubound of -1 is
|
|
indistinguishable from an assumed-size array in the callee. */
|
|
if (!sym->attr.is_bind_c && e && fsym && fsym->as
|
|
&& fsym->as->type == AS_ASSUMED_RANK
|
|
&& e->rank != -1
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& ((fsym->ts.type == BT_CLASS
|
|
&& !CLASS_DATA (fsym)->attr.class_pointer
|
|
&& !CLASS_DATA (fsym)->attr.allocatable)
|
|
|| (fsym->ts.type != BT_CLASS
|
|
&& !fsym->attr.pointer && !fsym->attr.allocatable)))
|
|
{
|
|
/* Change AR_FULL to a (:,:,:) ref to force bounds update. */
|
|
gfc_ref *ref;
|
|
for (ref = e->ref; ref->next; ref = ref->next)
|
|
;
|
|
if (ref->u.ar.type == AR_FULL
|
|
&& ref->u.ar.as->type != AS_ASSUMED_SIZE)
|
|
ref->u.ar.type = AR_SECTION;
|
|
}
|
|
|
|
if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
|
|
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
|
|
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
|
|
|
|
else if (e->expr_type == EXPR_VARIABLE
|
|
&& is_subref_array (e)
|
|
&& !(fsym && fsym->attr.pointer))
|
|
/* The actual argument is a component reference to an
|
|
array of derived types. In this case, the argument
|
|
is converted to a temporary, which is passed and then
|
|
written back after the procedure call. */
|
|
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
|
fsym ? fsym->attr.intent : INTENT_INOUT,
|
|
fsym && fsym->attr.pointer);
|
|
|
|
else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
|
|
&& CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
|
|
&& nodesc_arg && fsym->ts.type == BT_DERIVED)
|
|
/* An assumed size class actual argument being passed to
|
|
a 'no descriptor' formal argument just requires the
|
|
data pointer to be passed. For class dummy arguments
|
|
this is stored in the symbol backend decl.. */
|
|
parmse.expr = e->symtree->n.sym->backend_decl;
|
|
|
|
else if (gfc_is_class_array_ref (e, NULL)
|
|
&& fsym && fsym->ts.type == BT_DERIVED)
|
|
/* The actual argument is a component reference to an
|
|
array of derived types. In this case, the argument
|
|
is converted to a temporary, which is passed and then
|
|
written back after the procedure call.
|
|
OOP-TODO: Insert code so that if the dynamic type is
|
|
the same as the declared type, copy-in/copy-out does
|
|
not occur. */
|
|
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
|
fsym->attr.intent,
|
|
fsym->attr.pointer);
|
|
|
|
else if (gfc_is_class_array_function (e)
|
|
&& fsym && fsym->ts.type == BT_DERIVED)
|
|
/* See previous comment. For function actual argument,
|
|
the write out is not needed so the intent is set as
|
|
intent in. */
|
|
{
|
|
e->must_finalize = 1;
|
|
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
|
INTENT_IN, fsym->attr.pointer);
|
|
}
|
|
else if (fsym && fsym->attr.contiguous
|
|
&& !gfc_is_simply_contiguous (e, false, true)
|
|
&& gfc_expr_is_variable (e))
|
|
{
|
|
gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
|
|
fsym->attr.intent,
|
|
fsym->attr.pointer);
|
|
}
|
|
else
|
|
/* This is where we introduce a temporary to store the
|
|
result of a non-lvalue array expression. */
|
|
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
|
|
sym->name, NULL);
|
|
|
|
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
|
|
allocated on entry, it must be deallocated.
|
|
CFI descriptors are handled elsewhere. */
|
|
if (fsym && fsym->attr.allocatable
|
|
&& fsym->attr.intent == INTENT_OUT
|
|
&& !is_CFI_desc (fsym, NULL))
|
|
{
|
|
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);
|
|
/* But check whether dummy argument is optional. */
|
|
if (tmp != NULL_TREE
|
|
&& fsym->attr.optional
|
|
&& e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional)
|
|
{
|
|
tree present;
|
|
present = gfc_conv_expr_present (e->symtree->n.sym);
|
|
tmp = build3_v (COND_EXPR, present, tmp,
|
|
build_empty_stmt (input_location));
|
|
}
|
|
if (tmp != NULL_TREE)
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
|
|
tmp = parmse.expr;
|
|
/* With bind(C), the actual argument is replaced by a bind-C
|
|
descriptor; in this case, the data component arrives here,
|
|
which shall not be dereferenced, but still freed and
|
|
nullified. */
|
|
if (TREE_TYPE(tmp) != pvoid_type_node)
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
parmse.expr);
|
|
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)
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node,
|
|
gfc_conv_expr_present (e->symtree->n.sym),
|
|
tmp, build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
}
|
|
}
|
|
/* Special case for an assumed-rank dummy argument. */
|
|
if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
|
|
&& (fsym->ts.type == BT_CLASS
|
|
? (CLASS_DATA (fsym)->as
|
|
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|
|
: (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
|
|
{
|
|
if (fsym->ts.type == BT_CLASS
|
|
? (CLASS_DATA (fsym)->attr.class_pointer
|
|
|| CLASS_DATA (fsym)->attr.allocatable)
|
|
: (fsym->attr.pointer || fsym->attr.allocatable))
|
|
{
|
|
/* Unallocated allocatable arrays and unassociated pointer
|
|
arrays need their dtype setting if they are argument
|
|
associated with assumed rank dummies to set the rank. */
|
|
set_dtype_for_unallocated (&parmse, e);
|
|
}
|
|
else if (e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.dummy
|
|
&& (e->ts.type == BT_CLASS
|
|
? (e->ref && e->ref->next
|
|
&& e->ref->next->type == REF_ARRAY
|
|
&& e->ref->next->u.ar.type == AR_FULL
|
|
&& e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
|
|
: (e->ref && e->ref->type == REF_ARRAY
|
|
&& e->ref->u.ar.type == AR_FULL
|
|
&& e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
|
|
{
|
|
/* Assumed-size actual to assumed-rank dummy requires
|
|
dim[rank-1].ubound = -1. */
|
|
tree minus_one;
|
|
tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
|
|
if (fsym->ts.type == BT_CLASS)
|
|
tmp = gfc_class_data_get (tmp);
|
|
minus_one = build_int_cst (gfc_array_index_type, -1);
|
|
gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
|
|
gfc_rank_cst[e->rank - 1],
|
|
minus_one);
|
|
}
|
|
}
|
|
|
|
/* The case with fsym->attr.optional is that of a user subroutine
|
|
with an interface indicating an optional argument. When we call
|
|
an intrinsic subroutine, however, fsym is NULL, but we might still
|
|
have an optional argument, so we proceed to the substitution
|
|
just in case. */
|
|
if (e && (fsym == NULL || fsym->attr.optional))
|
|
{
|
|
/* If an optional argument is itself an optional dummy argument,
|
|
check its presence and substitute a null if absent. This is
|
|
only needed when passing an array to an elemental procedure
|
|
as then array elements are accessed - or no NULL pointer is
|
|
allowed and a "1" or "0" should be passed if not present.
|
|
When passing a non-array-descriptor full array to a
|
|
non-array-descriptor dummy, no check is needed. For
|
|
array-descriptor actual to array-descriptor dummy, see
|
|
PR 41911 for why a check has to be inserted.
|
|
fsym == NULL is checked as intrinsics required the descriptor
|
|
but do not always set fsym.
|
|
Also, it is necessary to pass a NULL pointer to library routines
|
|
which usually ignore optional arguments, so they can handle
|
|
these themselves. */
|
|
if (e->expr_type == EXPR_VARIABLE
|
|
&& e->symtree->n.sym->attr.optional
|
|
&& (((e->rank != 0 && elemental_proc)
|
|
|| e->representation.length || e->ts.type == BT_CHARACTER
|
|
|| (e->rank != 0
|
|
&& (fsym == NULL
|
|
|| (fsym->as
|
|
&& (fsym->as->type == AS_ASSUMED_SHAPE
|
|
|| fsym->as->type == AS_ASSUMED_RANK
|
|
|| fsym->as->type == AS_DEFERRED)))))
|
|
|| se->ignore_optional))
|
|
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
|
|
e->representation.length);
|
|
}
|
|
|
|
if (fsym && e)
|
|
{
|
|
/* Obtain the character length of an assumed character length
|
|
length procedure from the typespec. */
|
|
if (fsym->ts.type == BT_CHARACTER
|
|
&& parmse.string_length == NULL_TREE
|
|
&& e->ts.type == BT_PROCEDURE
|
|
&& e->symtree->n.sym->ts.type == BT_CHARACTER
|
|
&& e->symtree->n.sym->ts.u.cl->length != NULL
|
|
&& e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
|
{
|
|
gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
|
|
parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
|
|
}
|
|
}
|
|
|
|
if (fsym && need_interface_mapping && e)
|
|
gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
|
|
|
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
|
gfc_add_block_to_block (&post, &parmse.post);
|
|
|
|
/* Allocated allocatable components of derived types must be
|
|
deallocated for non-variable scalars, array arguments to elemental
|
|
procedures, and array arguments with descriptor to non-elemental
|
|
procedures. As bounds information for descriptorless arrays is no
|
|
longer available here, they are dealt with in trans-array.cc
|
|
(gfc_conv_array_parameter). */
|
|
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
|
|
&& e->ts.u.derived->attr.alloc_comp
|
|
&& (e->rank == 0 || elemental_proc || !nodesc_arg)
|
|
&& !expr_may_alias_variables (e, elemental_proc))
|
|
{
|
|
int parm_rank;
|
|
/* It is known the e returns a structure type with at least one
|
|
allocatable component. When e is a function, ensure that the
|
|
function is called once only by using a temporary variable. */
|
|
if (!DECL_P (parmse.expr))
|
|
parmse.expr = gfc_evaluate_now_loc (input_location,
|
|
parmse.expr, &se->pre);
|
|
|
|
if (fsym && fsym->attr.value)
|
|
tmp = parmse.expr;
|
|
else
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
parmse.expr);
|
|
|
|
parm_rank = e->rank;
|
|
switch (parm_kind)
|
|
{
|
|
case (ELEMENTAL):
|
|
case (SCALAR):
|
|
parm_rank = 0;
|
|
break;
|
|
|
|
case (SCALAR_POINTER):
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
tmp);
|
|
break;
|
|
}
|
|
|
|
if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
|
|
{
|
|
/* The derived type is passed to gfc_deallocate_alloc_comp.
|
|
Therefore, class actuals can be handled correctly but derived
|
|
types passed to class formals need the _data component. */
|
|
tmp = gfc_class_data_get (tmp);
|
|
if (!CLASS_DATA (fsym)->attr.dimension)
|
|
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
|
}
|
|
|
|
if (e->expr_type == EXPR_OP
|
|
&& e->value.op.op == INTRINSIC_PARENTHESES
|
|
&& e->value.op.op1->expr_type == EXPR_VARIABLE)
|
|
{
|
|
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, 0);
|
|
gfc_add_expr_to_block (&se->post, local_tmp);
|
|
}
|
|
|
|
if (!finalized && !e->must_finalize)
|
|
{
|
|
bool scalar_res_outside_loop;
|
|
scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
|
|
&& parm_rank == 0
|
|
&& parmse.loop;
|
|
|
|
/* Scalars passed to an assumed rank argument are converted to
|
|
a descriptor. Obtain the data field before deallocating any
|
|
allocatable components. */
|
|
if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
|
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
|
|
|
if (scalar_res_outside_loop)
|
|
{
|
|
/* Go through the ss chain to find the argument and use
|
|
the stored value. */
|
|
gfc_ss *tmp_ss = parmse.loop->ss;
|
|
for (; tmp_ss; tmp_ss = tmp_ss->next)
|
|
if (tmp_ss->info
|
|
&& tmp_ss->info->expr == e
|
|
&& tmp_ss->info->data.scalar.value != NULL_TREE)
|
|
{
|
|
tmp = tmp_ss->info->data.scalar.value;
|
|
break;
|
|
}
|
|
}
|
|
|
|
STRIP_NOPS (tmp);
|
|
|
|
if (derived_array != NULL_TREE)
|
|
tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
|
|
derived_array,
|
|
parm_rank);
|
|
else if ((e->ts.type == BT_CLASS
|
|
&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|
|
|| e->ts.type == BT_DERIVED)
|
|
tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
|
|
parm_rank);
|
|
else if (e->ts.type == BT_CLASS)
|
|
tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
|
|
tmp, parm_rank);
|
|
|
|
if (scalar_res_outside_loop)
|
|
gfc_add_expr_to_block (&parmse.loop->post, tmp);
|
|
else
|
|
gfc_prepend_expr_to_block (&post, tmp);
|
|
}
|
|
}
|
|
|
|
/* Add argument checking of passing an unallocated/NULL actual to
|
|
a nonallocatable/nonpointer dummy. */
|
|
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
|
|
{
|
|
symbol_attribute attr;
|
|
char *msg;
|
|
tree cond;
|
|
tree tmp;
|
|
symbol_attribute fsym_attr;
|
|
|
|
if (fsym)
|
|
{
|
|
if (fsym->ts.type == BT_CLASS)
|
|
{
|
|
fsym_attr = CLASS_DATA (fsym)->attr;
|
|
fsym_attr.pointer = fsym_attr.class_pointer;
|
|
}
|
|
else
|
|
fsym_attr = fsym->attr;
|
|
}
|
|
|
|
if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
|
|
attr = gfc_expr_attr (e);
|
|
else
|
|
goto end_pointer_check;
|
|
|
|
/* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
|
|
allocatable to an optional dummy, cf. 12.5.2.12. */
|
|
if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
|
|
&& (gfc_option.allow_std & GFC_STD_F2008) != 0)
|
|
goto end_pointer_check;
|
|
|
|
if (attr.optional)
|
|
{
|
|
/* If the actual argument is an optional pointer/allocatable and
|
|
the formal argument takes an nonpointer optional value,
|
|
it is invalid to pass a non-present argument on, even
|
|
though there is no technical reason for this in gfortran.
|
|
See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
|
|
tree present, null_ptr, type;
|
|
|
|
if (attr.allocatable
|
|
&& (fsym == NULL || !fsym_attr.allocatable))
|
|
msg = xasprintf ("Allocatable actual argument '%s' is not "
|
|
"allocated or not present",
|
|
e->symtree->n.sym->name);
|
|
else if (attr.pointer
|
|
&& (fsym == NULL || !fsym_attr.pointer))
|
|
msg = xasprintf ("Pointer actual argument '%s' is not "
|
|
"associated or not present",
|
|
e->symtree->n.sym->name);
|
|
else if (attr.proc_pointer && !e->value.function.actual
|
|
&& (fsym == NULL || !fsym_attr.proc_pointer))
|
|
msg = xasprintf ("Proc-pointer actual argument '%s' is not "
|
|
"associated or not present",
|
|
e->symtree->n.sym->name);
|
|
else
|
|
goto end_pointer_check;
|
|
|
|
present = gfc_conv_expr_present (e->symtree->n.sym);
|
|
type = TREE_TYPE (present);
|
|
present = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_type_node, present,
|
|
fold_convert (type,
|
|
null_pointer_node));
|
|
type = TREE_TYPE (parmse.expr);
|
|
null_ptr = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_type_node, parmse.expr,
|
|
fold_convert (type,
|
|
null_pointer_node));
|
|
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
|
|
logical_type_node, present, null_ptr);
|
|
}
|
|
else
|
|
{
|
|
if (attr.allocatable
|
|
&& (fsym == NULL || !fsym_attr.allocatable))
|
|
msg = xasprintf ("Allocatable actual argument '%s' is not "
|
|
"allocated", e->symtree->n.sym->name);
|
|
else if (attr.pointer
|
|
&& (fsym == NULL || !fsym_attr.pointer))
|
|
msg = xasprintf ("Pointer actual argument '%s' is not "
|
|
"associated", e->symtree->n.sym->name);
|
|
else if (attr.proc_pointer && !e->value.function.actual
|
|
&& (fsym == NULL || !fsym_attr.proc_pointer))
|
|
msg = xasprintf ("Proc-pointer actual argument '%s' is not "
|
|
"associated", e->symtree->n.sym->name);
|
|
else
|
|
goto end_pointer_check;
|
|
|
|
if (fsym && fsym->ts.type == BT_CLASS)
|
|
{
|
|
tmp = build_fold_indirect_ref_loc (input_location,
|
|
parmse.expr);
|
|
tmp = gfc_class_data_get (tmp);
|
|
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
|
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
|
}
|
|
else
|
|
tmp = parmse.expr;
|
|
|
|
/* If the argument is passed by value, we need to strip the
|
|
INDIRECT_REF. */
|
|
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
|
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
|
|
cond = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_type_node, tmp,
|
|
fold_convert (TREE_TYPE (tmp),
|
|
null_pointer_node));
|
|
}
|
|
|
|
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
|
|
msg);
|
|
free (msg);
|
|
}
|
|
end_pointer_check:
|
|
|
|
/* Deferred length dummies pass the character length by reference
|
|
so that the value can be returned. */
|
|
if (parmse.string_length && fsym && fsym->ts.deferred)
|
|
{
|
|
if (INDIRECT_REF_P (parmse.string_length))
|
|
/* In chains of functions/procedure calls the string_length already
|
|
is a pointer to the variable holding the length. Therefore
|
|
remove the deref on call. */
|
|
parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
|
|
else
|
|
{
|
|
tmp = parmse.string_length;
|
|
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);
|
|
}
|
|
}
|
|
|
|
/* Character strings are passed as two parameters, a length and a
|
|
pointer - except for Bind(c) which only passes the pointer.
|
|
An unlimited polymorphic formal argument likewise does not
|
|
need the length. */
|
|
if (parmse.string_length != NULL_TREE
|
|
&& !sym->attr.is_bind_c
|
|
&& !(fsym && UNLIMITED_POLY (fsym)))
|
|
vec_safe_push (stringargs, parmse.string_length);
|
|
|
|
/* When calling __copy for character expressions to unlimited
|
|
polymorphic entities, the dst argument needs a string length. */
|
|
if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
|
|
&& startswith (sym->name, "__vtab_CHARACTER")
|
|
&& arg->next && arg->next->expr
|
|
&& (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);
|
|
|
|
/* For descriptorless coarrays and assumed-shape coarray dummies, we
|
|
pass the token and the offset as additional arguments. */
|
|
if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
|
|
&& ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
|
|
&& !fsym->attr.allocatable)
|
|
|| (fsym->ts.type == BT_CLASS
|
|
&& CLASS_DATA (fsym)->attr.codimension
|
|
&& !CLASS_DATA (fsym)->attr.allocatable)))
|
|
{
|
|
/* Token and offset. */
|
|
vec_safe_push (stringargs, null_pointer_node);
|
|
vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
|
|
gcc_assert (fsym->attr.optional);
|
|
}
|
|
else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
|
|
&& ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
|
|
&& !fsym->attr.allocatable)
|
|
|| (fsym->ts.type == BT_CLASS
|
|
&& CLASS_DATA (fsym)->attr.codimension
|
|
&& !CLASS_DATA (fsym)->attr.allocatable)))
|
|
{
|
|
tree caf_decl, caf_type;
|
|
tree offset, tmp2;
|
|
|
|
caf_decl = gfc_get_tree_for_caf_expr (e);
|
|
caf_type = TREE_TYPE (caf_decl);
|
|
|
|
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
|
|
&& (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
|
|
|| GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
|
|
tmp = gfc_conv_descriptor_token (caf_decl);
|
|
else if (DECL_LANG_SPECIFIC (caf_decl)
|
|
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
|
|
tmp = GFC_DECL_TOKEN (caf_decl);
|
|
else
|
|
{
|
|
gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
|
|
&& GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
|
|
tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
|
|
}
|
|
|
|
vec_safe_push (stringargs, tmp);
|
|
|
|
if (GFC_DESCRIPTOR_TYPE_P (caf_type)
|
|
&& GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
|
|
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 (caf_type) != NULL_TREE)
|
|
offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
|
|
else
|
|
offset = build_int_cst (gfc_array_index_type, 0);
|
|
|
|
if (GFC_DESCRIPTOR_TYPE_P (caf_type))
|
|
tmp = gfc_conv_descriptor_data_get (caf_decl);
|
|
else
|
|
{
|
|
gcc_assert (POINTER_TYPE_P (caf_type));
|
|
tmp = caf_decl;
|
|
}
|
|
|
|
tmp2 = fsym->ts.type == BT_CLASS
|
|
? gfc_class_data_get (parmse.expr) : parmse.expr;
|
|
if ((fsym->ts.type != BT_CLASS
|
|
&& (fsym->as->type == AS_ASSUMED_SHAPE
|
|
|| fsym->as->type == AS_ASSUMED_RANK))
|
|
|| (fsym->ts.type == BT_CLASS
|
|
&& (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
|
|
|| CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
|
|
{
|
|
if (fsym->ts.type == BT_CLASS)
|
|
gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
|
|
else
|
|
{
|
|
gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
|
|
tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
|
|
}
|
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
|
|
tmp2 = gfc_conv_descriptor_data_get (tmp2);
|
|
}
|
|
else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
|
|
tmp2 = gfc_conv_descriptor_data_get (tmp2);
|
|
else
|
|
{
|
|
gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
|
|
}
|
|
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type,
|
|
fold_convert (gfc_array_index_type, tmp2),
|
|
fold_convert (gfc_array_index_type, tmp));
|
|
offset = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type, offset, tmp);
|
|
|
|
vec_safe_push (stringargs, offset);
|
|
}
|
|
|
|
vec_safe_push (arglist, parmse.expr);
|
|
}
|
|
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
|
|
|
|
if (comp)
|
|
ts = comp->ts;
|
|
else if (sym->ts.type == BT_CLASS)
|
|
ts = CLASS_DATA (sym)->ts;
|
|
else
|
|
ts = sym->ts;
|
|
|
|
if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
|
|
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
|
|
else if (ts.type == BT_CHARACTER)
|
|
{
|
|
if (ts.u.cl->length == NULL)
|
|
{
|
|
/* Assumed character length results are not allowed by C418 of the 2003
|
|
standard and are trapped in resolve.cc; except in the case of SPREAD
|
|
(and other intrinsics?) and dummy functions. In the case of SPREAD,
|
|
we take the character length of the first argument for the result.
|
|
For dummies, we have to look through the formal argument list for
|
|
this function and use the character length found there.*/
|
|
if (ts.deferred)
|
|
cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
|
|
else if (!sym->attr.dummy)
|
|
cl.backend_decl = (*stringargs)[0];
|
|
else
|
|
{
|
|
formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
|
|
for (; formal; formal = formal->next)
|
|
if (strcmp (formal->sym->name, sym->name) == 0)
|
|
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
|
|
}
|
|
len = cl.backend_decl;
|
|
}
|
|
else
|
|
{
|
|
tree tmp;
|
|
|
|
/* Calculate the length of the returned string. */
|
|
gfc_init_se (&parmse, NULL);
|
|
if (need_interface_mapping)
|
|
gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
|
|
else
|
|
gfc_conv_expr (&parmse, ts.u.cl->length);
|
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
|
gfc_add_block_to_block (&se->post, &parmse.post);
|
|
tmp = parmse.expr;
|
|
/* TODO: It would be better to have the charlens as
|
|
gfc_charlen_type_node already when the interface is
|
|
created instead of converting it here (see PR 84615). */
|
|
tmp = fold_build2_loc (input_location, MAX_EXPR,
|
|
gfc_charlen_type_node,
|
|
fold_convert (gfc_charlen_type_node, tmp),
|
|
build_zero_cst (gfc_charlen_type_node));
|
|
cl.backend_decl = tmp;
|
|
}
|
|
|
|
/* Set up a charlen structure for it. */
|
|
cl.next = NULL;
|
|
cl.length = NULL;
|
|
ts.u.cl = &cl;
|
|
|
|
len = cl.backend_decl;
|
|
}
|
|
|
|
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)
|
|
{
|
|
/* Sometimes, too much indirection can be applied; e.g. for
|
|
function_result = array_valued_recursive_function. */
|
|
if (TREE_TYPE (TREE_TYPE (se->expr))
|
|
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
|
|
&& GFC_DESCRIPTOR_TYPE_P
|
|
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
|
|
se->expr = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
|
|
/* If the lhs of an assignment x = f(..) is allocatable and
|
|
f2003 is allowed, we must do the automatic reallocation.
|
|
TODO - deal with intrinsics, without using a temporary. */
|
|
if (flag_realloc_lhs
|
|
&& se->ss && se->ss->loop_chain
|
|
&& se->ss->loop_chain->is_alloc_lhs
|
|
&& !expr->value.function.isym
|
|
&& sym->result->as != NULL)
|
|
{
|
|
/* Evaluate the bounds of the result, if known. */
|
|
gfc_set_loop_bounds_from_array_spec (&mapping, se,
|
|
sym->result->as);
|
|
|
|
/* Perform the automatic reallocation. */
|
|
tmp = gfc_alloc_allocatable_for_assignment (se->loop,
|
|
expr, NULL);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
|
/* Pass the temporary as the first argument. */
|
|
result = info->descriptor;
|
|
}
|
|
else
|
|
result = build_fold_indirect_ref_loc (input_location,
|
|
se->expr);
|
|
vec_safe_push (retargs, se->expr);
|
|
}
|
|
else if (comp && comp->attr.dimension)
|
|
{
|
|
gcc_assert (se->loop && info);
|
|
|
|
/* Set the type of the array. */
|
|
tmp = gfc_typenode_for_spec (&comp->ts);
|
|
gcc_assert (se->ss->dimen == se->loop->dimen);
|
|
|
|
/* Evaluate the bounds of the result, if known. */
|
|
gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
|
|
|
|
/* If the lhs of an assignment x = f(..) is allocatable and
|
|
f2003 is allowed, we must not generate the function call
|
|
here but should just send back the results of the mapping.
|
|
This is signalled by the function ss being flagged. */
|
|
if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
|
|
{
|
|
gfc_free_interface_mapping (&mapping);
|
|
return has_alternate_specifier;
|
|
}
|
|
|
|
/* Create a temporary to store the result. In case the function
|
|
returns a pointer, the temporary will be a shallow copy and
|
|
mustn't be deallocated. */
|
|
callee_alloc = comp->attr.allocatable || comp->attr.pointer;
|
|
gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
|
|
tmp, NULL_TREE, false,
|
|
!comp->attr.pointer, callee_alloc,
|
|
&se->ss->info->expr->where);
|
|
|
|
/* Pass the temporary as the first argument. */
|
|
result = info->descriptor;
|
|
tmp = gfc_build_addr_expr (NULL_TREE, result);
|
|
vec_safe_push (retargs, tmp);
|
|
}
|
|
else if (!comp && sym->result->attr.dimension)
|
|
{
|
|
gcc_assert (se->loop && info);
|
|
|
|
/* Set the type of the array. */
|
|
tmp = gfc_typenode_for_spec (&ts);
|
|
gcc_assert (se->ss->dimen == se->loop->dimen);
|
|
|
|
/* Evaluate the bounds of the result, if known. */
|
|
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
|
|
|
|
/* If the lhs of an assignment x = f(..) is allocatable and
|
|
f2003 is allowed, we must not generate the function call
|
|
here but should just send back the results of the mapping.
|
|
This is signalled by the function ss being flagged. */
|
|
if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
|
|
{
|
|
gfc_free_interface_mapping (&mapping);
|
|
return has_alternate_specifier;
|
|
}
|
|
|
|
/* Create a temporary to store the result. In case the function
|
|
returns a pointer, the temporary will be a shallow copy and
|
|
mustn't be deallocated. */
|
|
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
|
|
gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
|
|
tmp, NULL_TREE, false,
|
|
!sym->attr.pointer, callee_alloc,
|
|
&se->ss->info->expr->where);
|
|
|
|
/* Pass the temporary as the first argument. */
|
|
result = info->descriptor;
|
|
tmp = gfc_build_addr_expr (NULL_TREE, result);
|
|
vec_safe_push (retargs, tmp);
|
|
}
|
|
else if (ts.type == BT_CHARACTER)
|
|
{
|
|
/* Pass the string length. */
|
|
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))
|
|
|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
|
|
{
|
|
var = gfc_create_var (type, "pstr");
|
|
|
|
if ((!comp && sym->attr.allocatable)
|
|
|| (comp && comp->attr.allocatable))
|
|
{
|
|
gfc_add_modify (&se->pre, var,
|
|
fold_convert (TREE_TYPE (var),
|
|
null_pointer_node));
|
|
tmp = gfc_call_free (var);
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
}
|
|
|
|
/* Provide an address expression for the function arguments. */
|
|
var = gfc_build_addr_expr (NULL_TREE, var);
|
|
}
|
|
else
|
|
var = gfc_conv_string_tmp (se, type, len);
|
|
|
|
vec_safe_push (retargs, var);
|
|
}
|
|
else
|
|
{
|
|
gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
|
|
|
|
type = gfc_get_complex_type (ts.kind);
|
|
var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
|
|
vec_safe_push (retargs, var);
|
|
}
|
|
|
|
/* Add the string length to the argument list. */
|
|
if (ts.type == BT_CHARACTER && ts.deferred)
|
|
{
|
|
tmp = len;
|
|
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);
|
|
}
|
|
else if (ts.type == BT_CHARACTER)
|
|
vec_safe_push (retargs, len);
|
|
}
|
|
gfc_free_interface_mapping (&mapping);
|
|
|
|
/* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
|
|
arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
|
|
+ vec_safe_length (stringargs) + vec_safe_length (append_args));
|
|
vec_safe_reserve (retargs, arglen);
|
|
|
|
/* Add the return arguments. */
|
|
vec_safe_splice (retargs, arglist);
|
|
|
|
/* Add the hidden present status for optional+value to the arguments. */
|
|
vec_safe_splice (retargs, optionalargs);
|
|
|
|
/* Add the hidden string length parameters to the arguments. */
|
|
vec_safe_splice (retargs, stringargs);
|
|
|
|
/* We may want to append extra arguments here. This is used e.g. for
|
|
calls to libgfortran_matmul_??, which need extra information. */
|
|
vec_safe_splice (retargs, append_args);
|
|
|
|
arglist = retargs;
|
|
|
|
/* Generate the actual call. */
|
|
if (base_object == NULL_TREE)
|
|
conv_function_val (se, sym, expr, args);
|
|
else
|
|
conv_base_obj_fcn_val (se, base_object, expr);
|
|
|
|
/* If there are alternate return labels, function type should be
|
|
integer. Can't modify the type in place though, since it can be shared
|
|
with other functions. For dummy arguments, the typing is done to
|
|
this result, even if it has to be repeated for each call. */
|
|
if (has_alternate_specifier
|
|
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
|
|
{
|
|
if (!sym->attr.dummy)
|
|
{
|
|
TREE_TYPE (sym->backend_decl)
|
|
= build_function_type (integer_type_node,
|
|
TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
|
|
}
|
|
else
|
|
TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
|
|
}
|
|
|
|
fntype = TREE_TYPE (TREE_TYPE (se->expr));
|
|
se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
|
|
|
|
/* Allocatable scalar function results must be freed and nullified
|
|
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 && !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);
|
|
se->expr = tmp;
|
|
tmp = gfc_call_free (tmp);
|
|
gfc_add_expr_to_block (&post, tmp);
|
|
gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
|
|
}
|
|
|
|
/* If we have a pointer function, but we don't want a pointer, e.g.
|
|
something like
|
|
x = f()
|
|
where f is pointer valued, we have to dereference the result. */
|
|
if (!se->want_pointer && !byref
|
|
&& ((!comp && (sym->attr.pointer || sym->attr.allocatable))
|
|
|| (comp && (comp->attr.pointer || comp->attr.allocatable))))
|
|
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
|
|
|
|
/* f2c calling conventions require a scalar default real function to
|
|
return a double precision result. Convert this back to default
|
|
real. We only care about the cases that can happen in Fortran 77.
|
|
*/
|
|
if (flag_f2c && sym->ts.type == BT_REAL
|
|
&& sym->ts.kind == gfc_default_real_kind
|
|
&& !sym->attr.always_explicit)
|
|
se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
|
|
|
|
/* A pure function may still have side-effects - it may modify its
|
|
parameters. */
|
|
TREE_SIDE_EFFECTS (se->expr) = 1;
|
|
#if 0
|
|
if (!sym->attr.pure)
|
|
TREE_SIDE_EFFECTS (se->expr) = 1;
|
|
#endif
|
|
|
|
if (byref)
|
|
{
|
|
/* Add the function call to the pre chain. There is no expression. */
|
|
gfc_add_expr_to_block (&se->pre, se->expr);
|
|
se->expr = NULL_TREE;
|
|
|
|
if (!se->direct_byref)
|
|
{
|
|
if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
|
|
{
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
|
{
|
|
/* Check the data pointer hasn't been modified. This would
|
|
happen in a function returning a pointer. */
|
|
tmp = gfc_conv_descriptor_data_get (info->descriptor);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node,
|
|
tmp, info->data);
|
|
gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
|
|
gfc_msg_fault);
|
|
}
|
|
se->expr = info->descriptor;
|
|
/* Bundle in the string length. */
|
|
se->string_length = len;
|
|
}
|
|
else if (ts.type == BT_CHARACTER)
|
|
{
|
|
/* Dereference for character pointer results. */
|
|
if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
|
|
|| (comp && (comp->attr.pointer || comp->attr.allocatable)))
|
|
se->expr = build_fold_indirect_ref_loc (input_location, var);
|
|
else
|
|
se->expr = var;
|
|
|
|
se->string_length = len;
|
|
}
|
|
else
|
|
{
|
|
gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
|
|
se->expr = build_fold_indirect_ref_loc (input_location, var);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* 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);
|
|
/* -fcheck= can add diagnostic code, which has to be placed before
|
|
the call. */
|
|
if (parmse.pre.head != NULL)
|
|
gfc_add_expr_to_block (&se->pre, parmse.pre.head);
|
|
gcc_assert (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 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
|
|
&& 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
|
|
temporary here to prevent source allocatable components
|
|
from being corrupted. */
|
|
tmp2 = gfc_evaluate_now (result, &se->pre);
|
|
tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
|
|
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);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
|
|
/* Finally free the temporary's data field. */
|
|
tmp = gfc_conv_descriptor_data_get (tmp2);
|
|
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
|
|
NULL_TREE, NULL_TREE, true,
|
|
NULL, GFC_CAF_COARRAY_NOCOARRAY);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* For a function with a class array result, save the result as
|
|
a temporary, set the info fields needed by the scalarizer and
|
|
call the finalization function of the temporary. Note that the
|
|
nullification of allocatable components needed by the result
|
|
is done in gfc_trans_assignment_1. */
|
|
if (expr && ((gfc_is_class_array_function (expr)
|
|
&& se->ss && se->ss->loop)
|
|
|| gfc_is_alloc_class_scalar_function (expr))
|
|
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
|
|
&& expr->must_finalize)
|
|
{
|
|
tree final_fndecl;
|
|
tree is_final;
|
|
int n;
|
|
if (se->ss && se->ss->loop)
|
|
{
|
|
gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
|
|
se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
|
|
tmp = gfc_class_data_get (se->expr);
|
|
info->descriptor = tmp;
|
|
info->data = gfc_conv_descriptor_data_get (tmp);
|
|
info->offset = gfc_conv_descriptor_offset_get (tmp);
|
|
for (n = 0; n < se->ss->loop->dimen; n++)
|
|
{
|
|
tree dim = gfc_rank_cst[n];
|
|
se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
|
|
se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* TODO Eliminate the doubling of temporaries. This
|
|
one is necessary to ensure no memory leakage. */
|
|
se->expr = gfc_evaluate_now (se->expr, &se->pre);
|
|
tmp = gfc_class_data_get (se->expr);
|
|
tmp = gfc_conv_scalar_to_descriptor (se, tmp,
|
|
CLASS_DATA (expr->value.function.esym->result)->attr);
|
|
}
|
|
|
|
if ((gfc_is_class_array_function (expr)
|
|
|| gfc_is_alloc_class_scalar_function (expr))
|
|
&& CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
|
|
goto no_finalization;
|
|
|
|
final_fndecl = gfc_class_vtab_final_get (se->expr);
|
|
is_final = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node,
|
|
final_fndecl,
|
|
fold_convert (TREE_TYPE (final_fndecl),
|
|
null_pointer_node));
|
|
final_fndecl = build_fold_indirect_ref_loc (input_location,
|
|
final_fndecl);
|
|
tmp = build_call_expr_loc (input_location,
|
|
final_fndecl, 3,
|
|
gfc_build_addr_expr (NULL, tmp),
|
|
gfc_class_vtab_size_get (se->expr),
|
|
boolean_false_node);
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node, is_final, tmp,
|
|
build_empty_stmt (input_location));
|
|
|
|
if (se->ss && se->ss->loop)
|
|
{
|
|
gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node,
|
|
info->data,
|
|
fold_convert (TREE_TYPE (info->data),
|
|
null_pointer_node));
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node, tmp,
|
|
gfc_call_free (info->data),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&se->ss->loop->post, tmp);
|
|
}
|
|
else
|
|
{
|
|
tree classdata;
|
|
gfc_prepend_expr_to_block (&se->post, tmp);
|
|
classdata = gfc_class_data_get (se->expr);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node,
|
|
classdata,
|
|
fold_convert (TREE_TYPE (classdata),
|
|
null_pointer_node));
|
|
tmp = fold_build3_loc (input_location, COND_EXPR,
|
|
void_type_node, tmp,
|
|
gfc_call_free (classdata),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
}
|
|
}
|
|
|
|
no_finalization:
|
|
gfc_add_block_to_block (&se->post, &post);
|
|
}
|
|
|
|
return has_alternate_specifier;
|
|
}
|
|
|
|
|
|
/* Fill a character string with spaces. */
|
|
|
|
static tree
|
|
fill_with_spaces (tree start, tree type, tree size)
|
|
{
|
|
stmtblock_t block, loop;
|
|
tree i, el, exit_label, cond, tmp;
|
|
|
|
/* For a simple char type, we can call memset(). */
|
|
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
|
|
return build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMSET),
|
|
3, start,
|
|
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
|
|
lang_hooks.to_target_charset (' ')),
|
|
fold_convert (size_type_node, size));
|
|
|
|
/* Otherwise, we use a loop:
|
|
for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
|
|
*el = (type) ' ';
|
|
*/
|
|
|
|
/* Initialize variables. */
|
|
gfc_init_block (&block);
|
|
i = gfc_create_var (sizetype, "i");
|
|
gfc_add_modify (&block, i, fold_convert (sizetype, size));
|
|
el = gfc_create_var (build_pointer_type (type), "el");
|
|
gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
|
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
|
TREE_USED (exit_label) = 1;
|
|
|
|
|
|
/* Loop body. */
|
|
gfc_init_block (&loop);
|
|
|
|
/* Exit condition. */
|
|
cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
|
|
build_zero_cst (sizetype));
|
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&loop, tmp);
|
|
|
|
/* Assignment. */
|
|
gfc_add_modify (&loop,
|
|
fold_build1_loc (input_location, INDIRECT_REF, type, el),
|
|
build_int_cst (type, lang_hooks.to_target_charset (' ')));
|
|
|
|
/* Increment loop variables. */
|
|
gfc_add_modify (&loop, i,
|
|
fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
|
|
TYPE_SIZE_UNIT (type)));
|
|
gfc_add_modify (&loop, el,
|
|
fold_build_pointer_plus_loc (input_location,
|
|
el, TYPE_SIZE_UNIT (type)));
|
|
|
|
/* Making the loop... actually loop! */
|
|
tmp = gfc_finish_block (&loop);
|
|
tmp = build1_v (LOOP_EXPR, tmp);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
|
/* The exit label. */
|
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
/* Generate code to copy a string. */
|
|
|
|
void
|
|
gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
|
|
int dkind, tree slength, tree src, int skind)
|
|
{
|
|
tree tmp, dlen, slen;
|
|
tree dsc;
|
|
tree ssc;
|
|
tree cond;
|
|
tree cond2;
|
|
tree tmp2;
|
|
tree tmp3;
|
|
tree tmp4;
|
|
tree chartype;
|
|
stmtblock_t tempblock;
|
|
|
|
gcc_assert (dkind == skind);
|
|
|
|
if (slength != NULL_TREE)
|
|
{
|
|
slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
|
|
ssc = gfc_string_to_single_character (slen, src, skind);
|
|
}
|
|
else
|
|
{
|
|
slen = build_one_cst (gfc_charlen_type_node);
|
|
ssc = src;
|
|
}
|
|
|
|
if (dlength != NULL_TREE)
|
|
{
|
|
dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
|
|
dsc = gfc_string_to_single_character (dlen, dest, dkind);
|
|
}
|
|
else
|
|
{
|
|
dlen = build_one_cst (gfc_charlen_type_node);
|
|
dsc = dest;
|
|
}
|
|
|
|
/* Assign directly if the types are compatible. */
|
|
if (dsc != NULL_TREE && ssc != NULL_TREE
|
|
&& TREE_TYPE (dsc) == TREE_TYPE (ssc))
|
|
{
|
|
gfc_add_modify (block, dsc, ssc);
|
|
return;
|
|
}
|
|
|
|
/* The string copy algorithm below generates code like
|
|
|
|
if (destlen > 0)
|
|
{
|
|
if (srclen < destlen)
|
|
{
|
|
memmove (dest, src, srclen);
|
|
// Pad with spaces.
|
|
memset (&dest[srclen], ' ', destlen - srclen);
|
|
}
|
|
else
|
|
{
|
|
// Truncate if too long.
|
|
memmove (dest, src, destlen);
|
|
}
|
|
}
|
|
*/
|
|
|
|
/* Do nothing if the destination length is zero. */
|
|
cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
|
|
build_zero_cst (TREE_TYPE (dlen)));
|
|
|
|
/* For non-default character kinds, we have to multiply the string
|
|
length by the base type size. */
|
|
chartype = gfc_get_char_type (dkind);
|
|
slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
|
|
slen,
|
|
fold_convert (TREE_TYPE (slen),
|
|
TYPE_SIZE_UNIT (chartype)));
|
|
dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
|
|
dlen,
|
|
fold_convert (TREE_TYPE (dlen),
|
|
TYPE_SIZE_UNIT (chartype)));
|
|
|
|
if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
|
|
dest = fold_convert (pvoid_type_node, dest);
|
|
else
|
|
dest = gfc_build_addr_expr (pvoid_type_node, dest);
|
|
|
|
if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
|
|
src = fold_convert (pvoid_type_node, src);
|
|
else
|
|
src = gfc_build_addr_expr (pvoid_type_node, src);
|
|
|
|
/* Truncate string if source is too long. */
|
|
cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
|
|
dlen);
|
|
|
|
/* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
|
|
if (!CONSTANT_CLASS_P (cond2))
|
|
{
|
|
dest = gfc_evaluate_now (dest, block);
|
|
src = gfc_evaluate_now (src, block);
|
|
}
|
|
|
|
/* Copy and pad with spaces. */
|
|
tmp3 = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMMOVE),
|
|
3, dest, src,
|
|
fold_convert (size_type_node, slen));
|
|
|
|
/* 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, 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 truncated memmove if the slen >= dlen. */
|
|
tmp2 = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMMOVE),
|
|
3, dest, src,
|
|
fold_convert (size_type_node, dlen));
|
|
|
|
/* The whole copy_string function is there. */
|
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
|
|
tmp3, tmp2);
|
|
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);
|
|
}
|
|
|
|
|
|
/* Translate a statement function.
|
|
The value of a statement function reference is obtained by evaluating the
|
|
expression using the values of the actual arguments for the values of the
|
|
corresponding dummy arguments. */
|
|
|
|
static void
|
|
gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_symbol *sym;
|
|
gfc_symbol *fsym;
|
|
gfc_formal_arglist *fargs;
|
|
gfc_actual_arglist *args;
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
gfc_saved_var *saved_vars;
|
|
tree *temp_vars;
|
|
tree type;
|
|
tree tmp;
|
|
int n;
|
|
|
|
sym = expr->symtree->n.sym;
|
|
args = expr->value.function.actual;
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
n = 0;
|
|
for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
|
|
n++;
|
|
saved_vars = XCNEWVEC (gfc_saved_var, n);
|
|
temp_vars = XCNEWVEC (tree, n);
|
|
|
|
for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
|
|
fargs = fargs->next, n++)
|
|
{
|
|
/* Each dummy shall be specified, explicitly or implicitly, to be
|
|
scalar. */
|
|
gcc_assert (fargs->sym->attr.dimension == 0);
|
|
fsym = fargs->sym;
|
|
|
|
if (fsym->ts.type == BT_CHARACTER)
|
|
{
|
|
/* Copy string arguments. */
|
|
tree arglen;
|
|
|
|
gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
|
|
&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
|
|
|
|
/* Create a temporary to hold the value. */
|
|
if (fsym->ts.u.cl->backend_decl == NULL_TREE)
|
|
fsym->ts.u.cl->backend_decl
|
|
= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
|
|
|
|
type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
|
|
temp_vars[n] = gfc_create_var (type, fsym->name);
|
|
|
|
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
|
|
|
|
gfc_conv_expr (&rse, args->expr);
|
|
gfc_conv_string_parameter (&rse);
|
|
gfc_add_block_to_block (&se->pre, &lse.pre);
|
|
gfc_add_block_to_block (&se->pre, &rse.pre);
|
|
|
|
gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
|
|
rse.string_length, rse.expr, fsym->ts.kind);
|
|
gfc_add_block_to_block (&se->pre, &lse.post);
|
|
gfc_add_block_to_block (&se->pre, &rse.post);
|
|
}
|
|
else
|
|
{
|
|
/* For everything else, just evaluate the expression. */
|
|
|
|
/* Create a temporary to hold the value. */
|
|
type = gfc_typenode_for_spec (&fsym->ts);
|
|
temp_vars[n] = gfc_create_var (type, fsym->name);
|
|
|
|
gfc_conv_expr (&lse, args->expr);
|
|
|
|
gfc_add_block_to_block (&se->pre, &lse.pre);
|
|
gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
|
|
gfc_add_block_to_block (&se->pre, &lse.post);
|
|
}
|
|
|
|
args = args->next;
|
|
}
|
|
|
|
/* Use the temporary variables in place of the real ones. */
|
|
for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
|
|
fargs = fargs->next, n++)
|
|
gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
|
|
|
|
gfc_conv_expr (se, sym->value);
|
|
|
|
if (sym->ts.type == BT_CHARACTER)
|
|
{
|
|
gfc_conv_const_charlen (sym->ts.u.cl);
|
|
|
|
/* Force the expression to the correct length. */
|
|
if (!INTEGER_CST_P (se->string_length)
|
|
|| tree_int_cst_lt (se->string_length,
|
|
sym->ts.u.cl->backend_decl))
|
|
{
|
|
type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
|
|
tmp = gfc_create_var (type, sym->name);
|
|
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
|
|
gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
|
|
sym->ts.kind, se->string_length, se->expr,
|
|
sym->ts.kind);
|
|
se->expr = tmp;
|
|
}
|
|
se->string_length = sym->ts.u.cl->backend_decl;
|
|
}
|
|
|
|
/* Restore the original variables. */
|
|
for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
|
|
fargs = fargs->next, n++)
|
|
gfc_restore_sym (fargs->sym, &saved_vars[n]);
|
|
free (temp_vars);
|
|
free (saved_vars);
|
|
}
|
|
|
|
|
|
/* Translate a function expression. */
|
|
|
|
static void
|
|
gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_symbol *sym;
|
|
|
|
if (expr->value.function.isym)
|
|
{
|
|
gfc_conv_intrinsic_function (se, expr);
|
|
return;
|
|
}
|
|
|
|
/* expr.value.function.esym is the resolved (specific) function symbol for
|
|
most functions. However this isn't set for dummy procedures. */
|
|
sym = expr->value.function.esym;
|
|
if (!sym)
|
|
sym = expr->symtree->n.sym;
|
|
|
|
/* The IEEE_ARITHMETIC functions are caught here. */
|
|
if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
|
|
if (gfc_conv_ieee_arithmetic_function (se, expr))
|
|
return;
|
|
|
|
/* We distinguish statement functions from general functions to improve
|
|
runtime performance. */
|
|
if (sym->attr.proc == PROC_ST_FUNCTION)
|
|
{
|
|
gfc_conv_statement_function (se, expr);
|
|
return;
|
|
}
|
|
|
|
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
|
|
NULL);
|
|
}
|
|
|
|
|
|
/* Determine whether the given EXPR_CONSTANT is a zero initializer. */
|
|
|
|
static bool
|
|
is_zero_initializer_p (gfc_expr * expr)
|
|
{
|
|
if (expr->expr_type != EXPR_CONSTANT)
|
|
return false;
|
|
|
|
/* We ignore constants with prescribed memory representations for now. */
|
|
if (expr->representation.string)
|
|
return false;
|
|
|
|
switch (expr->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
return mpz_cmp_si (expr->value.integer, 0) == 0;
|
|
|
|
case BT_REAL:
|
|
return mpfr_zero_p (expr->value.real)
|
|
&& MPFR_SIGN (expr->value.real) >= 0;
|
|
|
|
case BT_LOGICAL:
|
|
return expr->value.logical == 0;
|
|
|
|
case BT_COMPLEX:
|
|
return mpfr_zero_p (mpc_realref (expr->value.complex))
|
|
&& MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
|
|
&& mpfr_zero_p (mpc_imagref (expr->value.complex))
|
|
&& MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
return false;
|
|
}
|
|
|
|
|
|
static void
|
|
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_ss *ss;
|
|
|
|
ss = se->ss;
|
|
gcc_assert (ss != NULL && ss != gfc_ss_terminator);
|
|
gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
|
|
|
|
gfc_conv_tmp_array_ref (se);
|
|
}
|
|
|
|
|
|
/* Build a static initializer. EXPR is the expression for the initial value.
|
|
The other parameters describe the variable of the component being
|
|
initialized. EXPR may be null. */
|
|
|
|
tree
|
|
gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
|
|
bool array, bool pointer, bool procptr)
|
|
{
|
|
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;
|
|
|
|
/* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
|
|
(these are the only two iso_c_binding derived types that can be
|
|
used as initialization expressions). If so, we need to modify
|
|
the 'expr' to be that for a (void *). */
|
|
if (expr != NULL && expr->ts.type == BT_DERIVED
|
|
&& expr->ts.is_iso_c && expr->ts.u.derived)
|
|
{
|
|
if (TREE_CODE (type) == ARRAY_TYPE)
|
|
return build_constructor (type, NULL);
|
|
else if (POINTER_TYPE_P (type))
|
|
return build_int_cst (type, 0);
|
|
else
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
if (array && !procptr)
|
|
{
|
|
tree ctor;
|
|
/* Arrays need special handling. */
|
|
if (pointer)
|
|
ctor = gfc_build_null_descriptor (type);
|
|
/* Special case assigning an array to zero. */
|
|
else if (is_zero_initializer_p (expr))
|
|
ctor = build_constructor (type, NULL);
|
|
else
|
|
ctor = gfc_conv_array_initializer (type, expr);
|
|
TREE_STATIC (ctor) = 1;
|
|
return ctor;
|
|
}
|
|
else if (pointer || procptr)
|
|
{
|
|
if (ts->type == BT_CLASS && !procptr)
|
|
{
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
|
|
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
|
|
TREE_STATIC (se.expr) = 1;
|
|
return se.expr;
|
|
}
|
|
else if (!expr || expr->expr_type == EXPR_NULL)
|
|
return fold_convert (type, null_pointer_node);
|
|
else
|
|
{
|
|
gfc_init_se (&se, NULL);
|
|
se.want_pointer = 1;
|
|
gfc_conv_expr (&se, expr);
|
|
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
|
|
return se.expr;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
switch (ts->type)
|
|
{
|
|
case_bt_struct:
|
|
case BT_CLASS:
|
|
gfc_init_se (&se, NULL);
|
|
if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
|
|
gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
|
|
else
|
|
gfc_conv_structure (&se, expr, 1);
|
|
gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
|
|
TREE_STATIC (se.expr) = 1;
|
|
return se.expr;
|
|
|
|
case BT_CHARACTER:
|
|
if (expr->expr_type == EXPR_CONSTANT)
|
|
{
|
|
tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
|
|
TREE_STATIC (ctor) = 1;
|
|
return ctor;
|
|
}
|
|
|
|
/* Fallthrough. */
|
|
default:
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_constant (&se, expr);
|
|
gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
|
|
return se.expr;
|
|
}
|
|
}
|
|
}
|
|
|
|
static tree
|
|
gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
|
|
{
|
|
gfc_se rse;
|
|
gfc_se lse;
|
|
gfc_ss *rss;
|
|
gfc_ss *lss;
|
|
gfc_array_info *lss_array;
|
|
stmtblock_t body;
|
|
stmtblock_t block;
|
|
gfc_loopinfo loop;
|
|
int n;
|
|
tree tmp;
|
|
|
|
gfc_start_block (&block);
|
|
|
|
/* Initialize the scalarizer. */
|
|
gfc_init_loopinfo (&loop);
|
|
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
/* Walk the rhs. */
|
|
rss = gfc_walk_expr (expr);
|
|
if (rss == gfc_ss_terminator)
|
|
/* The rhs is scalar. Add a ss for the expression. */
|
|
rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
|
|
|
|
/* Create a SS for the destination. */
|
|
lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
|
|
GFC_SS_COMPONENT);
|
|
lss_array = &lss->info->data.array;
|
|
lss_array->shape = gfc_get_shape (cm->as->rank);
|
|
lss_array->descriptor = dest;
|
|
lss_array->data = gfc_conv_array_data (dest);
|
|
lss_array->offset = gfc_conv_array_offset (dest);
|
|
for (n = 0; n < cm->as->rank; n++)
|
|
{
|
|
lss_array->start[n] = gfc_conv_array_lbound (dest, n);
|
|
lss_array->stride[n] = gfc_index_one_node;
|
|
|
|
mpz_init (lss_array->shape[n]);
|
|
mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
|
|
cm->as->lower[n]->value.integer);
|
|
mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
|
|
}
|
|
|
|
/* Associate the SS with the loop. */
|
|
gfc_add_ss_to_loop (&loop, lss);
|
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
|
/* Calculate the bounds of the scalarization. */
|
|
gfc_conv_ss_startstride (&loop);
|
|
|
|
/* Setup the scalarizing loops. */
|
|
gfc_conv_loop_setup (&loop, &expr->where);
|
|
|
|
/* Setup the gfc_se structures. */
|
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
|
rse.ss = rss;
|
|
gfc_mark_ss_chain_used (rss, 1);
|
|
lse.ss = lss;
|
|
gfc_mark_ss_chain_used (lss, 1);
|
|
|
|
/* Start the scalarized loop body. */
|
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
|
gfc_conv_tmp_array_ref (&lse);
|
|
if (cm->ts.type == BT_CHARACTER)
|
|
lse.string_length = cm->ts.u.cl->backend_decl;
|
|
|
|
gfc_conv_expr (&rse, expr);
|
|
|
|
tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
|
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
|
gcc_assert (rse.ss == gfc_ss_terminator);
|
|
|
|
/* Generate the copying loops. */
|
|
gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
|
/* Wrap the whole thing up. */
|
|
gfc_add_block_to_block (&block, &loop.pre);
|
|
gfc_add_block_to_block (&block, &loop.post);
|
|
|
|
gcc_assert (lss_array->shape != NULL);
|
|
gfc_free_shape (&lss_array->shape, cm->as->rank);
|
|
gfc_cleanup_loop (&loop);
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
static tree
|
|
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
|
|
gfc_expr * expr)
|
|
{
|
|
gfc_se se;
|
|
stmtblock_t block;
|
|
tree offset;
|
|
int n;
|
|
tree tmp;
|
|
tree tmp2;
|
|
gfc_array_spec *as;
|
|
gfc_expr *arg = NULL;
|
|
|
|
gfc_start_block (&block);
|
|
gfc_init_se (&se, NULL);
|
|
|
|
/* Get the descriptor for the expressions. */
|
|
se.want_pointer = 0;
|
|
gfc_conv_expr_descriptor (&se, expr);
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
gfc_add_modify (&block, dest, se.expr);
|
|
|
|
/* Deal with arrays of derived types with allocatable components. */
|
|
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, 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, 0);
|
|
else
|
|
{
|
|
tmp = TREE_TYPE (dest);
|
|
tmp = gfc_duplicate_allocatable (dest, se.expr,
|
|
tmp, expr->rank, NULL_TREE);
|
|
}
|
|
}
|
|
else
|
|
tmp = gfc_duplicate_allocatable (dest, se.expr,
|
|
TREE_TYPE(cm->backend_decl),
|
|
cm->as->rank, NULL_TREE);
|
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
gfc_add_block_to_block (&block, &se.post);
|
|
|
|
if (expr->expr_type != EXPR_VARIABLE)
|
|
gfc_conv_descriptor_data_set (&block, se.expr,
|
|
null_pointer_node);
|
|
|
|
/* We need to know if the argument of a conversion function is a
|
|
variable, so that the correct lower bound can be used. */
|
|
if (expr->expr_type == EXPR_FUNCTION
|
|
&& expr->value.function.isym
|
|
&& expr->value.function.isym->conversion
|
|
&& expr->value.function.actual->expr
|
|
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
|
|
arg = expr->value.function.actual->expr;
|
|
|
|
/* Obtain the array spec of full array references. */
|
|
if (arg)
|
|
as = gfc_get_full_arrayspec_from_expr (arg);
|
|
else
|
|
as = gfc_get_full_arrayspec_from_expr (expr);
|
|
|
|
/* Shift the lbound and ubound of temporaries to being unity,
|
|
rather than zero, based. Always calculate the offset. */
|
|
offset = gfc_conv_descriptor_offset_get (dest);
|
|
gfc_add_modify (&block, offset, gfc_index_zero_node);
|
|
tmp2 =gfc_create_var (gfc_array_index_type, NULL);
|
|
|
|
for (n = 0; n < expr->rank; n++)
|
|
{
|
|
tree span;
|
|
tree lbound;
|
|
|
|
/* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
|
|
TODO It looks as if gfc_conv_expr_descriptor should return
|
|
the correct bounds and that the following should not be
|
|
necessary. This would simplify gfc_conv_intrinsic_bound
|
|
as well. */
|
|
if (as && as->lower[n])
|
|
{
|
|
gfc_se lbse;
|
|
gfc_init_se (&lbse, NULL);
|
|
gfc_conv_expr (&lbse, as->lower[n]);
|
|
gfc_add_block_to_block (&block, &lbse.pre);
|
|
lbound = gfc_evaluate_now (lbse.expr, &block);
|
|
}
|
|
else if (as && arg)
|
|
{
|
|
tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
|
|
lbound = gfc_conv_descriptor_lbound_get (tmp,
|
|
gfc_rank_cst[n]);
|
|
}
|
|
else if (as)
|
|
lbound = gfc_conv_descriptor_lbound_get (dest,
|
|
gfc_rank_cst[n]);
|
|
else
|
|
lbound = gfc_index_one_node;
|
|
|
|
lbound = fold_convert (gfc_array_index_type, lbound);
|
|
|
|
/* Shift the bounds and set the offset accordingly. */
|
|
tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
|
|
span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
|
span, lbound);
|
|
gfc_conv_descriptor_ubound_set (&block, dest,
|
|
gfc_rank_cst[n], tmp);
|
|
gfc_conv_descriptor_lbound_set (&block, dest,
|
|
gfc_rank_cst[n], lbound);
|
|
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
gfc_conv_descriptor_lbound_get (dest,
|
|
gfc_rank_cst[n]),
|
|
gfc_conv_descriptor_stride_get (dest,
|
|
gfc_rank_cst[n]));
|
|
gfc_add_modify (&block, tmp2, tmp);
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
|
offset, tmp2);
|
|
gfc_conv_descriptor_offset_set (&block, dest, tmp);
|
|
}
|
|
|
|
if (arg)
|
|
{
|
|
/* If a conversion expression has a null data pointer
|
|
argument, nullify the allocatable component. */
|
|
tree non_null_expr;
|
|
tree null_expr;
|
|
|
|
if (arg->symtree->n.sym->attr.allocatable
|
|
|| arg->symtree->n.sym->attr.pointer)
|
|
{
|
|
non_null_expr = gfc_finish_block (&block);
|
|
gfc_start_block (&block);
|
|
gfc_conv_descriptor_data_set (&block, dest,
|
|
null_pointer_node);
|
|
null_expr = gfc_finish_block (&block);
|
|
tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
|
|
tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
|
|
fold_convert (TREE_TYPE (tmp), null_pointer_node));
|
|
return build3_v (COND_EXPR, tmp,
|
|
null_expr, non_null_expr);
|
|
}
|
|
}
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
/* Allocate or reallocate scalar component, as necessary. */
|
|
|
|
static void
|
|
alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
|
|
tree comp,
|
|
gfc_component *cm,
|
|
gfc_expr *expr2,
|
|
gfc_symbol *sym)
|
|
{
|
|
tree tmp;
|
|
tree ptr;
|
|
tree size;
|
|
tree size_in_bytes;
|
|
tree lhs_cl_size = NULL_TREE;
|
|
|
|
if (!comp)
|
|
return;
|
|
|
|
if (!expr2 || expr2->rank)
|
|
return;
|
|
|
|
realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
|
|
|
|
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
|
|
{
|
|
char name[GFC_MAX_SYMBOL_LEN+9];
|
|
gfc_component *strlen;
|
|
/* Use the rhs string length and the lhs element size. */
|
|
gcc_assert (expr2->ts.type == BT_CHARACTER);
|
|
if (!expr2->ts.u.cl->backend_decl)
|
|
{
|
|
gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
|
|
gcc_assert (expr2->ts.u.cl->backend_decl);
|
|
}
|
|
|
|
size = expr2->ts.u.cl->backend_decl;
|
|
|
|
/* 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, NULL);
|
|
lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
|
|
gfc_charlen_type_node,
|
|
TREE_OPERAND (comp, 0),
|
|
strlen->backend_decl, NULL_TREE);
|
|
|
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
|
|
tmp = TYPE_SIZE_UNIT (tmp);
|
|
size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
|
|
TREE_TYPE (tmp), tmp,
|
|
fold_convert (TREE_TYPE (tmp), size));
|
|
}
|
|
else if (cm->ts.type == BT_CLASS)
|
|
{
|
|
gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
|
|
if (expr2->ts.type == BT_DERIVED)
|
|
{
|
|
tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
|
|
size = TYPE_SIZE_UNIT (tmp);
|
|
}
|
|
else
|
|
{
|
|
gfc_expr *e2vtab;
|
|
gfc_se se;
|
|
e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
|
|
gfc_add_vptr_component (e2vtab);
|
|
gfc_add_size_component (e2vtab);
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_expr (&se, e2vtab);
|
|
gfc_add_block_to_block (block, &se.pre);
|
|
size = fold_convert (size_type_node, se.expr);
|
|
gfc_free_expr (e2vtab);
|
|
}
|
|
size_in_bytes = size;
|
|
}
|
|
else
|
|
{
|
|
/* Otherwise use the length in bytes of the rhs. */
|
|
size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
|
|
size_in_bytes = size;
|
|
}
|
|
|
|
size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
|
|
size_in_bytes, size_one_node);
|
|
|
|
if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
|
|
{
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_CALLOC),
|
|
2, build_one_cst (size_type_node),
|
|
size_in_bytes);
|
|
tmp = fold_convert (TREE_TYPE (comp), tmp);
|
|
gfc_add_modify (block, comp, tmp);
|
|
}
|
|
else
|
|
{
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MALLOC),
|
|
1, size_in_bytes);
|
|
if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
|
|
ptr = gfc_class_data_get (comp);
|
|
else
|
|
ptr = comp;
|
|
tmp = fold_convert (TREE_TYPE (ptr), tmp);
|
|
gfc_add_modify (block, ptr, tmp);
|
|
}
|
|
|
|
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
|
|
/* Update the lhs character length. */
|
|
gfc_add_modify (block, lhs_cl_size,
|
|
fold_convert (TREE_TYPE (lhs_cl_size), size));
|
|
}
|
|
|
|
|
|
/* Assign a single component of a derived type constructor. */
|
|
|
|
static tree
|
|
gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
|
|
gfc_symbol *sym, bool init)
|
|
{
|
|
gfc_se se;
|
|
gfc_se lse;
|
|
stmtblock_t block;
|
|
tree tmp;
|
|
tree vtab;
|
|
|
|
gfc_start_block (&block);
|
|
|
|
if (cm->attr.pointer || cm->attr.proc_pointer)
|
|
{
|
|
/* Only care about pointers here, not about allocatables. */
|
|
gfc_init_se (&se, NULL);
|
|
/* Pointer component. */
|
|
if ((cm->attr.dimension || cm->attr.codimension)
|
|
&& !cm->attr.proc_pointer)
|
|
{
|
|
/* Array pointer. */
|
|
if (expr->expr_type == EXPR_NULL)
|
|
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
|
|
else
|
|
{
|
|
se.direct_byref = 1;
|
|
se.expr = dest;
|
|
gfc_conv_expr_descriptor (&se, expr);
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
gfc_add_block_to_block (&block, &se.post);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* Scalar pointers. */
|
|
se.want_pointer = 1;
|
|
gfc_conv_expr (&se, expr);
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
|
if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
|
|
&& expr->symtree->n.sym->attr.dummy)
|
|
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
|
|
|
|
gfc_add_modify (&block, dest,
|
|
fold_convert (TREE_TYPE (dest), se.expr));
|
|
gfc_add_block_to_block (&block, &se.post);
|
|
}
|
|
}
|
|
else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
|
|
{
|
|
/* NULL initialization for CLASS components. */
|
|
tmp = gfc_trans_structure_assign (dest,
|
|
gfc_class_initializer (&cm->ts, expr),
|
|
false);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
else if ((cm->attr.dimension || cm->attr.codimension)
|
|
&& !cm->attr.proc_pointer)
|
|
{
|
|
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
|
|
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
|
|
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);
|
|
}
|
|
else
|
|
{
|
|
tmp = gfc_trans_subarray_assign (dest, cm, expr);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
}
|
|
else if (cm->ts.type == BT_CLASS
|
|
&& CLASS_DATA (cm)->attr.dimension
|
|
&& CLASS_DATA (cm)->attr.allocatable
|
|
&& expr->ts.type == BT_DERIVED)
|
|
{
|
|
vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
|
|
vtab = gfc_build_addr_expr (NULL_TREE, vtab);
|
|
tmp = gfc_class_vptr_get (dest);
|
|
gfc_add_modify (&block, tmp,
|
|
fold_convert (TREE_TYPE (tmp), vtab));
|
|
tmp = gfc_class_data_get (dest);
|
|
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)))
|
|
{
|
|
/* Take care about non-array allocatable components here. The alloc_*
|
|
routine below is motivated by the alloc_scalar_allocatable_for_
|
|
assignment() routine, but with the realloc portions removed and
|
|
different input. */
|
|
alloc_scalar_allocatable_for_subcomponent_assignment (&block,
|
|
dest,
|
|
cm,
|
|
expr,
|
|
sym);
|
|
/* The remainder of these instructions follow the if (cm->attr.pointer)
|
|
if (!cm->attr.dimension) part above. */
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_expr (&se, expr);
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
|
if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
|
|
&& expr->symtree->n.sym->attr.dummy)
|
|
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
|
|
|
|
if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
|
|
{
|
|
tmp = gfc_class_data_get (dest);
|
|
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
|
vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
|
|
vtab = gfc_build_addr_expr (NULL_TREE, vtab);
|
|
gfc_add_modify (&block, gfc_class_vptr_get (dest),
|
|
fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
|
|
}
|
|
else
|
|
tmp = build_fold_indirect_ref_loc (input_location, dest);
|
|
|
|
/* For deferred strings insert a memcpy. */
|
|
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
|
|
{
|
|
tree size;
|
|
gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
|
|
size = size_of_string_in_bytes (cm->ts.kind, se.string_length
|
|
? se.string_length
|
|
: expr->ts.u.cl->backend_decl);
|
|
tmp = gfc_build_memcpy_call (tmp, se.expr, size);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
else
|
|
gfc_add_modify (&block, tmp,
|
|
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)
|
|
{
|
|
tree dealloc = NULL_TREE;
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_expr (&se, expr);
|
|
gfc_add_block_to_block (&block, &se.pre);
|
|
/* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
|
|
expression in a temporary variable and deallocate the allocatable
|
|
components. Then we can the copy the expression to the result. */
|
|
if (cm->ts.u.derived->attr.alloc_comp
|
|
&& expr->expr_type != EXPR_VARIABLE)
|
|
{
|
|
se.expr = gfc_evaluate_now (se.expr, &block);
|
|
dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
|
|
expr->rank);
|
|
}
|
|
gfc_add_modify (&block, dest,
|
|
fold_convert (TREE_TYPE (dest), se.expr));
|
|
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, 0);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
if (dealloc != NULL_TREE)
|
|
gfc_add_expr_to_block (&block, dealloc);
|
|
}
|
|
gfc_add_block_to_block (&block, &se.post);
|
|
}
|
|
else
|
|
{
|
|
/* Nested constructors. */
|
|
tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
}
|
|
else if (gfc_deferred_strlen (cm, &tmp))
|
|
{
|
|
tree strlen;
|
|
strlen = tmp;
|
|
gcc_assert (strlen);
|
|
strlen = fold_build3_loc (input_location, COMPONENT_REF,
|
|
TREE_TYPE (strlen),
|
|
TREE_OPERAND (dest, 0),
|
|
strlen, NULL_TREE);
|
|
|
|
if (expr->expr_type == EXPR_NULL)
|
|
{
|
|
tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
|
|
gfc_add_modify (&block, dest, tmp);
|
|
tmp = build_int_cst (TREE_TYPE (strlen), 0);
|
|
gfc_add_modify (&block, strlen, tmp);
|
|
}
|
|
else
|
|
{
|
|
tree size;
|
|
gfc_init_se (&se, NULL);
|
|
gfc_conv_expr (&se, expr);
|
|
size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MALLOC),
|
|
1, size);
|
|
gfc_add_modify (&block, dest,
|
|
fold_convert (TREE_TYPE (dest), tmp));
|
|
gfc_add_modify (&block, strlen,
|
|
fold_convert (TREE_TYPE (strlen), se.string_length));
|
|
tmp = gfc_build_memcpy_call (dest, se.expr, size);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
}
|
|
else if (!cm->attr.artificial)
|
|
{
|
|
/* Scalar component (excluding deferred parameters). */
|
|
gfc_init_se (&se, NULL);
|
|
gfc_init_se (&lse, NULL);
|
|
|
|
gfc_conv_expr (&se, expr);
|
|
if (cm->ts.type == BT_CHARACTER)
|
|
lse.string_length = cm->ts.u.cl->backend_decl;
|
|
lse.expr = dest;
|
|
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
/* Assign a derived type constructor to a variable. */
|
|
|
|
tree
|
|
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);
|
|
|
|
if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
|
|
&& (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
|
|
|| expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
|
|
{
|
|
gfc_se lse;
|
|
|
|
gfc_init_se (&se, NULL);
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
|
|
lse.expr = dest;
|
|
gfc_add_modify (&block, lse.expr,
|
|
fold_convert (TREE_TYPE (lse.expr), se.expr));
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
/* Make sure that the derived type has been completely built. */
|
|
if (!expr->ts.u.derived->backend_decl
|
|
|| !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
|
|
{
|
|
tmp = gfc_typenode_for_spec (&expr->ts);
|
|
gcc_assert (tmp);
|
|
}
|
|
|
|
cm = expr->ts.u.derived->components;
|
|
|
|
|
|
if (coarray)
|
|
gfc_init_se (&se, NULL);
|
|
|
|
for (c = gfc_constructor_first (expr->value.constructor);
|
|
c; c = gfc_constructor_next (c), cm = cm->next)
|
|
{
|
|
/* Skip absent members in default initializers. */
|
|
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 = build_zero_cst (size_type_node);
|
|
desc = field;
|
|
gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
|
|
build_int_cst (signed_char_type_node, 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;
|
|
gcc_assert(field);
|
|
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
|
|
dest, field, NULL_TREE);
|
|
if (!c->expr)
|
|
{
|
|
gfc_expr *e = gfc_get_null_expr (NULL);
|
|
tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
|
|
init);
|
|
gfc_free_expr (e);
|
|
}
|
|
else
|
|
tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
|
|
expr->ts.u.derived, init);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
static 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. */
|
|
|
|
void
|
|
gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
|
|
{
|
|
gfc_constructor *c;
|
|
gfc_component *cm;
|
|
tree val;
|
|
tree type;
|
|
tree tmp;
|
|
vec<constructor_elt, va_gc> *v = NULL;
|
|
|
|
gcc_assert (se->ss == NULL);
|
|
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
|
|
type = gfc_typenode_for_spec (&expr->ts);
|
|
|
|
if (!init)
|
|
{
|
|
/* Create a temporary variable and fill it in. */
|
|
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,
|
|
se->want_coarray);
|
|
gfc_add_expr_to_block (&se->pre, tmp);
|
|
return;
|
|
}
|
|
|
|
cm = expr->ts.u.derived->components;
|
|
|
|
for (c = gfc_constructor_first (expr->value.constructor);
|
|
c; c = gfc_constructor_next (c), cm = cm->next)
|
|
{
|
|
/* Skip absent members in default initializers and allocatable
|
|
components. Although the latter have a default initializer
|
|
of EXPR_NULL,... by default, the static nullify is not needed
|
|
since this is done every time we come into scope. */
|
|
if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
|
|
continue;
|
|
|
|
if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
|
|
&& strcmp (cm->name, "_extends") == 0
|
|
&& cm->initializer->symtree)
|
|
{
|
|
tree vtab;
|
|
gfc_symbol *vtabs;
|
|
vtabs = cm->initializer->symtree->n.sym;
|
|
vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
|
|
vtab = unshare_expr_without_location (vtab);
|
|
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
|
|
}
|
|
else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
|
|
{
|
|
val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
|
|
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
|
|
fold_convert (TREE_TYPE (cm->backend_decl),
|
|
val));
|
|
}
|
|
else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
|
|
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,
|
|
TREE_TYPE (cm->backend_decl),
|
|
cm->attr.dimension, cm->attr.pointer,
|
|
cm->attr.proc_pointer);
|
|
val = unshare_expr_without_location (val);
|
|
|
|
/* Append it to the constructor list. */
|
|
CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
|
|
}
|
|
}
|
|
|
|
se->expr = build_constructor (type, v);
|
|
if (init)
|
|
TREE_CONSTANT (se->expr) = 1;
|
|
}
|
|
|
|
|
|
/* Translate a substring expression. */
|
|
|
|
static void
|
|
gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_ref *ref;
|
|
|
|
ref = expr->ref;
|
|
|
|
gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
|
|
|
|
se->expr = gfc_build_wide_string_const (expr->ts.kind,
|
|
expr->value.character.length,
|
|
expr->value.character.string);
|
|
|
|
se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
|
|
TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
|
|
|
|
if (ref)
|
|
gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
|
|
}
|
|
|
|
|
|
/* Entry point for expression translation. Evaluates a scalar quantity.
|
|
EXPR is the expression to be translated, and SE is the state structure if
|
|
called from within the scalarized. */
|
|
|
|
void
|
|
gfc_conv_expr (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_ss *ss;
|
|
|
|
ss = se->ss;
|
|
if (ss && ss->info->expr == expr
|
|
&& (ss->info->type == GFC_SS_SCALAR
|
|
|| ss->info->type == GFC_SS_REFERENCE))
|
|
{
|
|
gfc_ss_info *ss_info;
|
|
|
|
ss_info = ss->info;
|
|
/* Substitute a scalar expression evaluated outside the scalarization
|
|
loop. */
|
|
se->expr = ss_info->data.scalar.value;
|
|
if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
|
|
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
|
|
|
|
se->string_length = ss_info->string_length;
|
|
gfc_advance_se_ss_chain (se);
|
|
return;
|
|
}
|
|
|
|
/* We need to convert the expressions for the iso_c_binding derived types.
|
|
C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
|
|
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
|
|
typespec for the C_PTR and C_FUNPTR symbols, which has already been
|
|
updated to be an integer with a kind equal to the size of a (void *). */
|
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
|
|
&& expr->ts.u.derived->attr.is_bind_c)
|
|
{
|
|
if (expr->expr_type == EXPR_VARIABLE
|
|
&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
|
|
|| expr->symtree->n.sym->intmod_sym_id
|
|
== ISOCBINDING_NULL_FUNPTR))
|
|
{
|
|
/* Set expr_type to EXPR_NULL, which will result in
|
|
null_pointer_node being used below. */
|
|
expr->expr_type = EXPR_NULL;
|
|
}
|
|
else
|
|
{
|
|
/* Update the type/kind of the expression to be what the new
|
|
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
|
|
expr->ts.type = BT_INTEGER;
|
|
expr->ts.f90_type = BT_VOID;
|
|
expr->ts.kind = gfc_index_integer_kind;
|
|
}
|
|
}
|
|
|
|
gfc_fix_class_refs (expr);
|
|
|
|
switch (expr->expr_type)
|
|
{
|
|
case EXPR_OP:
|
|
gfc_conv_expr_op (se, expr);
|
|
break;
|
|
|
|
case EXPR_FUNCTION:
|
|
gfc_conv_function_expr (se, expr);
|
|
break;
|
|
|
|
case EXPR_CONSTANT:
|
|
gfc_conv_constant (se, expr);
|
|
break;
|
|
|
|
case EXPR_VARIABLE:
|
|
gfc_conv_variable (se, expr);
|
|
break;
|
|
|
|
case EXPR_NULL:
|
|
se->expr = null_pointer_node;
|
|
break;
|
|
|
|
case EXPR_SUBSTRING:
|
|
gfc_conv_substring_expr (se, expr);
|
|
break;
|
|
|
|
case EXPR_STRUCTURE:
|
|
gfc_conv_structure (se, expr, 0);
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
gfc_conv_array_constructor_expr (se, expr);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
|
|
of an assignment. */
|
|
void
|
|
gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
gfc_conv_expr (se, expr);
|
|
/* All numeric lvalues should have empty post chains. If not we need to
|
|
figure out a way of rewriting an lvalue so that it has no post chain. */
|
|
gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
|
|
}
|
|
|
|
/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
|
|
numeric expressions. Used for scalar values where inserting cleanup code
|
|
is inconvenient. */
|
|
void
|
|
gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
|
|
{
|
|
tree val;
|
|
|
|
gcc_assert (expr->ts.type != BT_CHARACTER);
|
|
gfc_conv_expr (se, expr);
|
|
if (se->post.head)
|
|
{
|
|
val = gfc_create_var (TREE_TYPE (se->expr), NULL);
|
|
gfc_add_modify (&se->pre, val, se->expr);
|
|
se->expr = val;
|
|
gfc_add_block_to_block (&se->pre, &se->post);
|
|
}
|
|
}
|
|
|
|
/* Helper to translate an expression and convert it to a particular type. */
|
|
void
|
|
gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
|
|
{
|
|
gfc_conv_expr_val (se, expr);
|
|
se->expr = convert (type, se->expr);
|
|
}
|
|
|
|
|
|
/* Converts an expression so that it can be passed by reference. Scalar
|
|
values only. */
|
|
|
|
void
|
|
gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
|
|
{
|
|
gfc_ss *ss;
|
|
tree var;
|
|
|
|
ss = se->ss;
|
|
if (ss && ss->info->expr == expr
|
|
&& ss->info->type == GFC_SS_REFERENCE)
|
|
{
|
|
/* Returns a reference to the scalar evaluated outside the loop
|
|
for this case. */
|
|
gfc_conv_expr (se, expr);
|
|
|
|
if (expr->ts.type == BT_CHARACTER
|
|
&& expr->expr_type != EXPR_FUNCTION)
|
|
gfc_conv_string_parameter (se);
|
|
else
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
|
|
|
return;
|
|
}
|
|
|
|
if (expr->ts.type == BT_CHARACTER)
|
|
{
|
|
gfc_conv_expr (se, expr);
|
|
gfc_conv_string_parameter (se);
|
|
return;
|
|
}
|
|
|
|
if (expr->expr_type == EXPR_VARIABLE)
|
|
{
|
|
se->want_pointer = 1;
|
|
gfc_conv_expr (se, expr);
|
|
if (se->post.head)
|
|
{
|
|
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
|
|
gfc_add_modify (&se->pre, var, se->expr);
|
|
gfc_add_block_to_block (&se->pre, &se->post);
|
|
se->expr = var;
|
|
}
|
|
else if (add_clobber && expr->ref == NULL)
|
|
{
|
|
tree clobber;
|
|
tree var;
|
|
/* FIXME: This fails if var is passed by reference, see PR
|
|
41453. */
|
|
var = expr->symtree->n.sym->backend_decl;
|
|
clobber = build_clobber (TREE_TYPE (var));
|
|
gfc_add_modify (&se->pre, var, clobber);
|
|
}
|
|
return;
|
|
}
|
|
|
|
if (expr->expr_type == EXPR_FUNCTION
|
|
&& ((expr->value.function.esym
|
|
&& expr->value.function.esym->result
|
|
&& expr->value.function.esym->result->attr.pointer
|
|
&& !expr->value.function.esym->result->attr.dimension)
|
|
|| (!expr->value.function.esym && !expr->ref
|
|
&& expr->symtree->n.sym->attr.pointer
|
|
&& !expr->symtree->n.sym->attr.dimension)))
|
|
{
|
|
se->want_pointer = 1;
|
|
gfc_conv_expr (se, expr);
|
|
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
|
|
gfc_add_modify (&se->pre, var, se->expr);
|
|
se->expr = var;
|
|
return;
|
|
}
|
|
|
|
gfc_conv_expr (se, expr);
|
|
|
|
/* Create a temporary var to hold the value. */
|
|
if (TREE_CONSTANT (se->expr))
|
|
{
|
|
tree tmp = se->expr;
|
|
STRIP_TYPE_NOPS (tmp);
|
|
var = build_decl (input_location,
|
|
CONST_DECL, NULL, TREE_TYPE (tmp));
|
|
DECL_INITIAL (var) = tmp;
|
|
TREE_STATIC (var) = 1;
|
|
pushdecl (var);
|
|
}
|
|
else
|
|
{
|
|
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
|
|
gfc_add_modify (&se->pre, var, se->expr);
|
|
}
|
|
|
|
if (!expr->must_finalize)
|
|
gfc_add_block_to_block (&se->pre, &se->post);
|
|
|
|
/* Take the address of that value. */
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, var);
|
|
}
|
|
|
|
|
|
/* 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;
|
|
tree class_expr = NULL_TREE;
|
|
|
|
/* 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))
|
|
{
|
|
if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
|
|
class_expr = gfc_get_class_from_expr (rse->expr);
|
|
|
|
if (rse->loop)
|
|
pre = &rse->loop->pre;
|
|
else
|
|
pre = &rse->pre;
|
|
|
|
if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
|
|
{
|
|
tmp = TREE_OPERAND (rse->expr, 0);
|
|
tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
|
|
gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
|
|
}
|
|
else
|
|
{
|
|
tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
|
|
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 && re->ts.type == BT_CLASS)
|
|
? 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;
|
|
if (class_expr)
|
|
tmp = class_expr;
|
|
else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
|
|
tmp = gfc_get_class_from_expr (rse->expr);
|
|
else
|
|
tmp = rse->expr;
|
|
|
|
se.expr = gfc_class_vptr_get (tmp);
|
|
if (UNLIMITED_POLY (re))
|
|
from_len = gfc_class_len_get (tmp);
|
|
|
|
}
|
|
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)
|
|
{
|
|
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 = build_zero_cst (gfc_charlen_type_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);
|
|
}
|
|
}
|
|
|
|
|
|
/* Do everything that is needed for a CLASS function expr2. */
|
|
|
|
static tree
|
|
trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
|
|
gfc_expr *expr1, gfc_expr *expr2)
|
|
{
|
|
tree expr1_vptr = NULL_TREE;
|
|
tree tmp;
|
|
|
|
gfc_conv_function_expr (rse, expr2);
|
|
rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
|
|
|
|
if (expr1->ts.type != BT_CLASS)
|
|
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_modify (&lse->pre, expr1_vptr,
|
|
fold_convert (TREE_TYPE (expr1_vptr),
|
|
gfc_class_vptr_get (tmp)));
|
|
rse->expr = gfc_class_data_get (tmp);
|
|
}
|
|
|
|
return expr1_vptr;
|
|
}
|
|
|
|
|
|
tree
|
|
gfc_trans_pointer_assign (gfc_code * code)
|
|
{
|
|
return gfc_trans_pointer_assignment (code->expr1, code->expr2);
|
|
}
|
|
|
|
|
|
/* Generate code for a pointer assignment. */
|
|
|
|
tree
|
|
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
|
|
{
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
stmtblock_t block;
|
|
tree desc;
|
|
tree tmp;
|
|
tree expr1_vptr = NULL_TREE;
|
|
bool scalar, non_proc_ptr_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_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
|
|
&& expr2->expr_type == EXPR_VARIABLE
|
|
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
|
|
|
|
/* 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);
|
|
scalar = ss == gfc_ss_terminator;
|
|
if (!scalar)
|
|
gfc_free_ss_chain (ss);
|
|
|
|
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
|
|
&& expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
|
|
{
|
|
gfc_add_data_component (expr2);
|
|
/* The following is required as gfc_add_data_component doesn't
|
|
update ts.type if there is a trailing REF_ARRAY. */
|
|
expr2->ts.type = BT_DERIVED;
|
|
}
|
|
|
|
if (scalar)
|
|
{
|
|
/* Scalar pointers. */
|
|
lse.want_pointer = 1;
|
|
gfc_conv_expr (&lse, expr1);
|
|
gfc_init_se (&rse, NULL);
|
|
rse.want_pointer = 1;
|
|
if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
|
|
trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
|
|
else
|
|
gfc_conv_expr (&rse, expr2);
|
|
|
|
if (non_proc_ptr_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,
|
|
lse.expr);
|
|
|
|
if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
|
|
&& expr2->symtree->n.sym->attr.dummy)
|
|
rse.expr = build_fold_indirect_ref_loc (input_location,
|
|
rse.expr);
|
|
|
|
gfc_add_block_to_block (&block, &lse.pre);
|
|
gfc_add_block_to_block (&block, &rse.pre);
|
|
|
|
/* Check character lengths if character expression. The test is only
|
|
really added if -fbounds-check is enabled. Exclude deferred
|
|
character length lefthand sides. */
|
|
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
|
|
&& !expr1->ts.deferred
|
|
&& !expr1->symtree->n.sym->attr.proc_pointer
|
|
&& !gfc_is_proc_ptr_comp (expr1))
|
|
{
|
|
gcc_assert (expr2->ts.type == BT_CHARACTER);
|
|
gcc_assert (lse.string_length && rse.string_length);
|
|
gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
|
|
lse.string_length, rse.string_length,
|
|
&block);
|
|
}
|
|
|
|
/* The assignment to an deferred character length sets the string
|
|
length to that of the rhs. */
|
|
if (expr1->ts.deferred)
|
|
{
|
|
if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
|
|
gfc_add_modify (&block, lse.string_length,
|
|
fold_convert (TREE_TYPE (lse.string_length),
|
|
rse.string_length));
|
|
else if (lse.string_length != NULL)
|
|
gfc_add_modify (&block, lse.string_length,
|
|
build_zero_cst (TREE_TYPE (lse.string_length)));
|
|
}
|
|
|
|
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);
|
|
}
|
|
else
|
|
{
|
|
gfc_ref* remap;
|
|
bool rank_remap;
|
|
tree strlen_lhs;
|
|
tree strlen_rhs = NULL_TREE;
|
|
|
|
/* Array pointer. Find the last reference on the LHS and if it is an
|
|
array section ref, we're dealing with bounds remapping. In this case,
|
|
set it to AR_FULL so that gfc_conv_expr_descriptor does
|
|
not see it and process the bounds remapping afterwards explicitly. */
|
|
for (remap = expr1->ref; remap; remap = remap->next)
|
|
if (!remap->next && remap->type == REF_ARRAY
|
|
&& remap->u.ar.type == AR_SECTION)
|
|
break;
|
|
rank_remap = (remap && remap->u.ar.end[0]);
|
|
|
|
if (remap && expr2->expr_type == EXPR_NULL)
|
|
{
|
|
gfc_error ("If bounds remapping is specified at %L, "
|
|
"the pointer target shall not be NULL", &expr1->where);
|
|
return NULL_TREE;
|
|
}
|
|
|
|
gfc_init_se (&lse, NULL);
|
|
if (remap)
|
|
lse.descriptor_only = 1;
|
|
gfc_conv_expr_descriptor (&lse, expr1);
|
|
strlen_lhs = lse.string_length;
|
|
desc = lse.expr;
|
|
|
|
if (expr2->expr_type == EXPR_NULL)
|
|
{
|
|
/* Just set the data pointer to null. */
|
|
gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
|
|
}
|
|
else if (rank_remap)
|
|
{
|
|
/* If we are rank-remapping, just get the RHS's descriptor and
|
|
process this later on. */
|
|
gfc_init_se (&rse, NULL);
|
|
rse.direct_byref = 1;
|
|
rse.byref_noassign = 1;
|
|
|
|
if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
|
|
expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
|
|
expr1, expr2);
|
|
else if (expr2->expr_type == EXPR_FUNCTION)
|
|
{
|
|
tree bound[GFC_MAX_DIMENSIONS];
|
|
int i;
|
|
|
|
for (i = 0; i < expr2->rank; i++)
|
|
bound[i] = NULL_TREE;
|
|
tmp = gfc_typenode_for_spec (&expr2->ts);
|
|
tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
|
|
bound, bound, 0,
|
|
GFC_ARRAY_POINTER_CONT, false);
|
|
tmp = gfc_create_var (tmp, "ptrtemp");
|
|
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)
|
|
{
|
|
/* Assign directly to the LHS's descriptor. */
|
|
lse.descriptor_only = 0;
|
|
lse.direct_byref = 1;
|
|
gfc_conv_expr_descriptor (&lse, expr2);
|
|
strlen_rhs = lse.string_length;
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
if (expr1->ts.type == BT_CLASS)
|
|
{
|
|
rse.expr = NULL_TREE;
|
|
rse.string_length = strlen_rhs;
|
|
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
|
|
NULL, NULL);
|
|
}
|
|
|
|
if (remap == NULL)
|
|
{
|
|
/* If the target is not a whole array, use the target array
|
|
reference for remap. */
|
|
for (remap = expr2->ref; remap; remap = remap->next)
|
|
if (remap->type == REF_ARRAY
|
|
&& remap->u.ar.type == AR_FULL
|
|
&& remap->next)
|
|
break;
|
|
}
|
|
}
|
|
else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
|
|
{
|
|
gfc_init_se (&rse, NULL);
|
|
rse.want_pointer = 1;
|
|
gfc_conv_function_expr (&rse, expr2);
|
|
if (expr1->ts.type != BT_CLASS)
|
|
{
|
|
rse.expr = gfc_class_data_get (rse.expr);
|
|
gfc_add_modify (&lse.pre, desc, rse.expr);
|
|
/* Set the lhs span. */
|
|
tmp = TREE_TYPE (rse.expr);
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
|
|
tmp = fold_convert (gfc_array_index_type, tmp);
|
|
gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
|
|
}
|
|
else
|
|
{
|
|
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
|
|
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_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);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* Assign to a temporary descriptor and then copy that
|
|
temporary to the pointer. */
|
|
tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
|
|
lse.descriptor_only = 0;
|
|
lse.expr = tmp;
|
|
lse.direct_byref = 1;
|
|
gfc_conv_expr_descriptor (&lse, expr2);
|
|
strlen_rhs = lse.string_length;
|
|
gfc_add_modify (&lse.pre, desc, tmp);
|
|
}
|
|
|
|
if (expr1->ts.type == BT_CHARACTER
|
|
&& expr1->symtree->n.sym->ts.deferred
|
|
&& expr1->symtree->n.sym->ts.u.cl->backend_decl
|
|
&& VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
|
|
{
|
|
tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
|
|
if (expr2->expr_type != EXPR_NULL)
|
|
gfc_add_modify (&block, tmp,
|
|
fold_convert (TREE_TYPE (tmp), strlen_rhs));
|
|
else
|
|
gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
|
|
}
|
|
|
|
gfc_add_block_to_block (&block, &lse.pre);
|
|
if (rank_remap)
|
|
gfc_add_block_to_block (&block, &rse.pre);
|
|
|
|
/* If we do bounds remapping, update LHS descriptor accordingly. */
|
|
if (remap)
|
|
{
|
|
int dim;
|
|
gcc_assert (remap->u.ar.dimen == expr1->rank);
|
|
|
|
if (rank_remap)
|
|
{
|
|
/* Do rank remapping. We already have the RHS's descriptor
|
|
converted in rse and now have to build the correct LHS
|
|
descriptor for it. */
|
|
|
|
tree dtype, data, span;
|
|
tree offs, stride;
|
|
tree lbound, ubound;
|
|
|
|
/* Set dtype. */
|
|
dtype = gfc_conv_descriptor_dtype (desc);
|
|
tmp = gfc_get_dtype (TREE_TYPE (desc));
|
|
gfc_add_modify (&block, dtype, tmp);
|
|
|
|
/* Copy data pointer. */
|
|
data = gfc_conv_descriptor_data_get (rse.expr);
|
|
gfc_conv_descriptor_data_set (&block, desc, data);
|
|
|
|
/* Copy the span. */
|
|
if (TREE_CODE (rse.expr) == VAR_DECL
|
|
&& GFC_DECL_PTR_ARRAY_P (rse.expr))
|
|
span = gfc_conv_descriptor_span_get (rse.expr);
|
|
else
|
|
{
|
|
tmp = TREE_TYPE (rse.expr);
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
|
|
span = fold_convert (gfc_array_index_type, tmp);
|
|
}
|
|
gfc_conv_descriptor_span_set (&block, desc, span);
|
|
|
|
/* Copy offset but adjust it such that it would correspond
|
|
to a lbound of zero. */
|
|
offs = gfc_conv_descriptor_offset_get (rse.expr);
|
|
for (dim = 0; dim < expr2->rank; ++dim)
|
|
{
|
|
stride = gfc_conv_descriptor_stride_get (rse.expr,
|
|
gfc_rank_cst[dim]);
|
|
lbound = gfc_conv_descriptor_lbound_get (rse.expr,
|
|
gfc_rank_cst[dim]);
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, stride, lbound);
|
|
offs = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type, offs, tmp);
|
|
}
|
|
gfc_conv_descriptor_offset_set (&block, desc, offs);
|
|
|
|
/* Set the bounds as declared for the LHS and calculate strides as
|
|
well as another offset update accordingly. */
|
|
stride = gfc_conv_descriptor_stride_get (rse.expr,
|
|
gfc_rank_cst[0]);
|
|
for (dim = 0; dim < expr1->rank; ++dim)
|
|
{
|
|
gfc_se lower_se;
|
|
gfc_se upper_se;
|
|
|
|
gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
|
|
|
|
/* Convert declared bounds. */
|
|
gfc_init_se (&lower_se, NULL);
|
|
gfc_init_se (&upper_se, NULL);
|
|
gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
|
|
gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
|
|
|
|
gfc_add_block_to_block (&block, &lower_se.pre);
|
|
gfc_add_block_to_block (&block, &upper_se.pre);
|
|
|
|
lbound = fold_convert (gfc_array_index_type, lower_se.expr);
|
|
ubound = fold_convert (gfc_array_index_type, upper_se.expr);
|
|
|
|
lbound = gfc_evaluate_now (lbound, &block);
|
|
ubound = gfc_evaluate_now (ubound, &block);
|
|
|
|
gfc_add_block_to_block (&block, &lower_se.post);
|
|
gfc_add_block_to_block (&block, &upper_se.post);
|
|
|
|
/* Set bounds in descriptor. */
|
|
gfc_conv_descriptor_lbound_set (&block, desc,
|
|
gfc_rank_cst[dim], lbound);
|
|
gfc_conv_descriptor_ubound_set (&block, desc,
|
|
gfc_rank_cst[dim], ubound);
|
|
|
|
/* Set stride. */
|
|
stride = gfc_evaluate_now (stride, &block);
|
|
gfc_conv_descriptor_stride_set (&block, desc,
|
|
gfc_rank_cst[dim], stride);
|
|
|
|
/* Update offset. */
|
|
offs = gfc_conv_descriptor_offset_get (desc);
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, lbound, stride);
|
|
offs = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type, offs, tmp);
|
|
offs = gfc_evaluate_now (offs, &block);
|
|
gfc_conv_descriptor_offset_set (&block, desc, offs);
|
|
|
|
/* Update stride. */
|
|
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
|
|
stride = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, stride, tmp);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* Bounds remapping. Just shift the lower bounds. */
|
|
|
|
gcc_assert (expr1->rank == expr2->rank);
|
|
|
|
for (dim = 0; dim < remap->u.ar.dimen; ++dim)
|
|
{
|
|
gfc_se lbound_se;
|
|
|
|
gcc_assert (!remap->u.ar.end[dim]);
|
|
gfc_init_se (&lbound_se, NULL);
|
|
if (remap->u.ar.start[dim])
|
|
{
|
|
gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
|
|
gfc_add_block_to_block (&block, &lbound_se.pre);
|
|
}
|
|
else
|
|
/* This remap arises from a target that is not a whole
|
|
array. The start expressions will be NULL but we need
|
|
the lbounds to be one. */
|
|
lbound_se.expr = gfc_index_one_node;
|
|
gfc_conv_shift_descriptor_lbound (&block, desc,
|
|
dim, lbound_se.expr);
|
|
gfc_add_block_to_block (&block, &lbound_se.post);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* If rank remapping was done, check with -fcheck=bounds that
|
|
the target is at least as large as the pointer. */
|
|
if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
|
|
{
|
|
tree lsize, rsize;
|
|
tree fault;
|
|
const char* msg;
|
|
|
|
lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
|
|
rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
|
|
|
|
lsize = gfc_evaluate_now (lsize, &block);
|
|
rsize = gfc_evaluate_now (rsize, &block);
|
|
fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
|
|
rsize, lsize);
|
|
|
|
msg = _("Target of rank remapping is too small (%ld < %ld)");
|
|
gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
|
|
msg, rsize, lsize);
|
|
}
|
|
|
|
/* Check string lengths if applicable. The check is only really added
|
|
to the output code if -fbounds-check is enabled. */
|
|
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
|
|
{
|
|
gcc_assert (expr2->ts.type == BT_CHARACTER);
|
|
gcc_assert (strlen_lhs && strlen_rhs);
|
|
gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
|
|
strlen_lhs, strlen_rhs, &block);
|
|
}
|
|
|
|
gfc_add_block_to_block (&block, &lse.post);
|
|
if (rank_remap)
|
|
gfc_add_block_to_block (&block, &rse.post);
|
|
}
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
/* Makes sure se is suitable for passing as a function string parameter. */
|
|
/* TODO: Need to check all callers of this function. It may be abused. */
|
|
|
|
void
|
|
gfc_conv_string_parameter (gfc_se * se)
|
|
{
|
|
tree type;
|
|
|
|
if (TREE_CODE (se->expr) == STRING_CST)
|
|
{
|
|
type = TREE_TYPE (TREE_TYPE (se->expr));
|
|
se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
|
|
return;
|
|
}
|
|
|
|
if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
|
|
|| TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
|
|
&& TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
|
|
{
|
|
if (TREE_CODE (se->expr) != INDIRECT_REF)
|
|
{
|
|
type = TREE_TYPE (se->expr);
|
|
se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
|
|
}
|
|
else
|
|
{
|
|
type = gfc_get_character_type_len (gfc_default_character_kind,
|
|
se->string_length);
|
|
type = build_pointer_type (type);
|
|
se->expr = gfc_build_addr_expr (type, se->expr);
|
|
}
|
|
}
|
|
|
|
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
|
|
}
|
|
|
|
|
|
/* Generate code for assignment of scalar variables. Includes character
|
|
strings and derived types with allocatable components.
|
|
If you know that the LHS has no allocations, set dealloc to false.
|
|
|
|
DEEP_COPY has no effect if the typespec TS is not a derived type with
|
|
allocatable components. Otherwise, if it is set, an explicit copy of each
|
|
allocatable component is made. This is necessary as a simple copy of the
|
|
whole object would copy array descriptors as is, so that the lhs's
|
|
allocatable components would point to the rhs's after the assignment.
|
|
Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
|
|
necessary if the rhs is a non-pointer function, as the allocatable components
|
|
are not accessible by other means than the function's result after the
|
|
function has returned. It is even more subtle when temporaries are involved,
|
|
as the two following examples show:
|
|
1. When we evaluate an array constructor, a temporary is created. Thus
|
|
there is theoretically no alias possible. However, no deep copy is
|
|
made for this temporary, so that if the constructor is made of one or
|
|
more variable with allocatable components, those components still point
|
|
to the variable's: DEEP_COPY should be set for the assignment from the
|
|
temporary to the lhs in that case.
|
|
2. When assigning a scalar to an array, we evaluate the scalar value out
|
|
of the loop, store it into a temporary variable, and assign from that.
|
|
In that case, deep copying when assigning to the temporary would be a
|
|
waste of resources; however deep copies should happen when assigning from
|
|
the temporary to each array element: again DEEP_COPY should be set for
|
|
the assignment from the temporary to the lhs. */
|
|
|
|
tree
|
|
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
|
|
bool deep_copy, bool dealloc, bool in_coarray)
|
|
{
|
|
stmtblock_t block;
|
|
tree tmp;
|
|
tree cond;
|
|
|
|
gfc_init_block (&block);
|
|
|
|
if (ts.type == BT_CHARACTER)
|
|
{
|
|
tree rlen = NULL;
|
|
tree llen = NULL;
|
|
|
|
if (lse->string_length != NULL_TREE)
|
|
{
|
|
gfc_conv_string_parameter (lse);
|
|
gfc_add_block_to_block (&block, &lse->pre);
|
|
llen = lse->string_length;
|
|
}
|
|
|
|
if (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 (gfc_bt_struct (ts.type)
|
|
&& (ts.u.derived->attr.alloc_comp
|
|
|| (deep_copy && ts.u.derived->attr.pdt_type)))
|
|
{
|
|
tree tmp_var = NULL_TREE;
|
|
cond = NULL_TREE;
|
|
|
|
/* Are the rhs and the lhs the same? */
|
|
if (deep_copy)
|
|
{
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
|
|
gfc_build_addr_expr (NULL_TREE, lse->expr),
|
|
gfc_build_addr_expr (NULL_TREE, rse->expr));
|
|
cond = gfc_evaluate_now (cond, &lse->pre);
|
|
}
|
|
|
|
/* Deallocate the lhs allocated components as long as it is not
|
|
the same as the rhs. This must be done following the assignment
|
|
to prevent deallocating data that could be used in the rhs
|
|
expression. */
|
|
if (dealloc)
|
|
{
|
|
tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
|
|
tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
|
|
if (deep_copy)
|
|
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
|
|
tmp);
|
|
gfc_add_expr_to_block (&lse->post, tmp);
|
|
}
|
|
|
|
gfc_add_block_to_block (&block, &rse->pre);
|
|
gfc_add_block_to_block (&block, &lse->pre);
|
|
|
|
gfc_add_modify (&block, lse->expr,
|
|
fold_convert (TREE_TYPE (lse->expr), rse->expr));
|
|
|
|
/* Restore pointer address of coarray components. */
|
|
if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
|
|
{
|
|
tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
|
|
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
|
|
tmp);
|
|
gfc_add_expr_to_block (&block, tmp);
|
|
}
|
|
|
|
/* Do a deep copy if the rhs is a variable, if it is not the
|
|
same as the lhs. */
|
|
if (deep_copy)
|
|
{
|
|
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 (gfc_bt_struct (ts.type))
|
|
{
|
|
gfc_add_block_to_block (&block, &lse->pre);
|
|
gfc_add_block_to_block (&block, &rse->pre);
|
|
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
|
|
TREE_TYPE (lse->expr), rse->expr);
|
|
gfc_add_modify (&block, lse->expr, tmp);
|
|
}
|
|
/* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
|
|
else if (ts.type == BT_CLASS)
|
|
{
|
|
gfc_add_block_to_block (&block, &lse->pre);
|
|
gfc_add_block_to_block (&block, &rse->pre);
|
|
|
|
if (!trans_scalar_class_assign (&block, lse, rse))
|
|
{
|
|
/* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
|
|
for the lhs which ensures that class data rhs cast as a string assigns
|
|
correctly. */
|
|
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
|
|
TREE_TYPE (rse->expr), lse->expr);
|
|
gfc_add_modify (&block, tmp, rse->expr);
|
|
}
|
|
}
|
|
else if (ts.type != BT_CLASS)
|
|
{
|
|
gfc_add_block_to_block (&block, &lse->pre);
|
|
gfc_add_block_to_block (&block, &rse->pre);
|
|
|
|
gfc_add_modify (&block, lse->expr,
|
|
fold_convert (TREE_TYPE (lse->expr), rse->expr));
|
|
}
|
|
|
|
gfc_add_block_to_block (&block, &lse->post);
|
|
gfc_add_block_to_block (&block, &rse->post);
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
/* There are quite a lot of restrictions on the optimisation in using an
|
|
array function assign without a temporary. */
|
|
|
|
static bool
|
|
arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
|
|
{
|
|
gfc_ref * ref;
|
|
bool seen_array_ref;
|
|
bool c = false;
|
|
gfc_symbol *sym = expr1->symtree->n.sym;
|
|
|
|
/* Play it safe with class functions assigned to a derived type. */
|
|
if (gfc_is_class_array_function (expr2)
|
|
&& expr1->ts.type == BT_DERIVED)
|
|
return true;
|
|
|
|
/* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
|
|
if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
|
|
return true;
|
|
|
|
/* Elemental functions are scalarized so that they don't need a
|
|
temporary in gfc_trans_assignment_1, so return a true. Otherwise,
|
|
they would need special treatment in gfc_trans_arrayfunc_assign. */
|
|
if (expr2->value.function.esym != NULL
|
|
&& expr2->value.function.esym->attr.elemental)
|
|
return true;
|
|
|
|
/* Need a temporary if rhs is not FULL or a contiguous section. */
|
|
if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
|
|
return true;
|
|
|
|
/* Need a temporary if EXPR1 can't be expressed as a descriptor. */
|
|
if (gfc_ref_needs_temporary_p (expr1->ref))
|
|
return true;
|
|
|
|
/* Functions returning pointers or allocatables need temporaries. */
|
|
if (gfc_expr_attr (expr2).pointer
|
|
|| gfc_expr_attr (expr2).allocatable)
|
|
return true;
|
|
|
|
/* Character array functions need temporaries unless the
|
|
character lengths are the same. */
|
|
if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
|
|
{
|
|
if (expr1->ts.u.cl->length == NULL
|
|
|| expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
|
|
return true;
|
|
|
|
if (expr2->ts.u.cl->length == NULL
|
|
|| expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
|
|
return true;
|
|
|
|
if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
|
|
expr2->ts.u.cl->length->value.integer) != 0)
|
|
return true;
|
|
}
|
|
|
|
/* Check that no LHS component references appear during an array
|
|
reference. This is needed because we do not have the means to
|
|
span any arbitrary stride with an array descriptor. This check
|
|
is not needed for the rhs because the function result has to be
|
|
a complete type. */
|
|
seen_array_ref = false;
|
|
for (ref = expr1->ref; ref; ref = ref->next)
|
|
{
|
|
if (ref->type == REF_ARRAY)
|
|
seen_array_ref= true;
|
|
else if (ref->type == REF_COMPONENT && seen_array_ref)
|
|
return true;
|
|
}
|
|
|
|
/* Check for a dependency. */
|
|
if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
|
|
expr2->value.function.esym,
|
|
expr2->value.function.actual,
|
|
NOT_ELEMENTAL))
|
|
return true;
|
|
|
|
/* If we have reached here with an intrinsic function, we do not
|
|
need a temporary except in the particular case that reallocation
|
|
on assignment is active and the lhs is allocatable and a target,
|
|
or a pointer which may be a subref pointer. FIXME: The last
|
|
condition can go away when we use span in the intrinsics
|
|
directly.*/
|
|
if (expr2->value.function.isym)
|
|
return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
|
|
|| (sym->attr.pointer && sym->attr.subref_array_pointer);
|
|
|
|
/* If the LHS is a dummy, we need a temporary if it is not
|
|
INTENT(OUT). */
|
|
if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
|
|
return true;
|
|
|
|
/* If the lhs has been host_associated, is in common, a pointer or is
|
|
a target and the function is not using a RESULT variable, aliasing
|
|
can occur and a temporary is needed. */
|
|
if ((sym->attr.host_assoc
|
|
|| sym->attr.in_common
|
|
|| sym->attr.pointer
|
|
|| sym->attr.cray_pointee
|
|
|| sym->attr.target)
|
|
&& expr2->symtree != NULL
|
|
&& expr2->symtree->n.sym == expr2->symtree->n.sym->result)
|
|
return true;
|
|
|
|
/* A PURE function can unconditionally be called without a temporary. */
|
|
if (expr2->value.function.esym != NULL
|
|
&& expr2->value.function.esym->attr.pure)
|
|
return false;
|
|
|
|
/* Implicit_pure functions are those which could legally be declared
|
|
to be PURE. */
|
|
if (expr2->value.function.esym != NULL
|
|
&& expr2->value.function.esym->attr.implicit_pure)
|
|
return false;
|
|
|
|
if (!sym->attr.use_assoc
|
|
&& !sym->attr.in_common
|
|
&& !sym->attr.pointer
|
|
&& !sym->attr.target
|
|
&& !sym->attr.cray_pointee
|
|
&& expr2->value.function.esym)
|
|
{
|
|
/* A temporary is not needed if the function is not contained and
|
|
the variable is local or host associated and not a pointer or
|
|
a target. */
|
|
if (!expr2->value.function.esym->attr.contained)
|
|
return false;
|
|
|
|
/* A temporary is not needed if the lhs has never been host
|
|
associated and the procedure is contained. */
|
|
else if (!sym->attr.host_assoc)
|
|
return false;
|
|
|
|
/* A temporary is not needed if the variable is local and not
|
|
a pointer, a target or a result. */
|
|
if (sym->ns->parent
|
|
&& expr2->value.function.esym->ns == sym->ns->parent)
|
|
return false;
|
|
}
|
|
|
|
/* Default to temporary use. */
|
|
return true;
|
|
}
|
|
|
|
|
|
/* Provide the loop info so that the lhs descriptor can be built for
|
|
reallocatable assignments from extrinsic function calls. */
|
|
|
|
static void
|
|
realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
|
|
gfc_loopinfo *loop)
|
|
{
|
|
/* Signal that the function call should not be made by
|
|
gfc_conv_loop_setup. */
|
|
se->ss->is_alloc_lhs = 1;
|
|
gfc_init_loopinfo (loop);
|
|
gfc_add_ss_to_loop (loop, *ss);
|
|
gfc_add_ss_to_loop (loop, se->ss);
|
|
gfc_conv_ss_startstride (loop);
|
|
gfc_conv_loop_setup (loop, where);
|
|
gfc_copy_loopinfo_to_se (se, loop);
|
|
gfc_add_block_to_block (&se->pre, &loop->pre);
|
|
gfc_add_block_to_block (&se->pre, &loop->post);
|
|
se->ss->is_alloc_lhs = 0;
|
|
}
|
|
|
|
|
|
/* For assignment to a reallocatable lhs from intrinsic functions,
|
|
replace the se.expr (ie. the result) with a temporary descriptor.
|
|
Null the data field so that the library allocates space for the
|
|
result. Free the data of the original descriptor after the function,
|
|
in case it appears in an argument expression and transfer the
|
|
result to the original descriptor. */
|
|
|
|
static void
|
|
fcncall_realloc_result (gfc_se *se, int rank)
|
|
{
|
|
tree desc;
|
|
tree res_desc;
|
|
tree tmp;
|
|
tree offset;
|
|
tree zero_cond;
|
|
tree not_same_shape;
|
|
stmtblock_t shape_block;
|
|
int n;
|
|
|
|
/* Use the allocation done by the library. Substitute the lhs
|
|
descriptor with a copy, whose data field is nulled.*/
|
|
desc = build_fold_indirect_ref_loc (input_location, se->expr);
|
|
if (POINTER_TYPE_P (TREE_TYPE (desc)))
|
|
desc = build_fold_indirect_ref_loc (input_location, desc);
|
|
|
|
/* Unallocated, the descriptor does not have a dtype. */
|
|
tmp = gfc_conv_descriptor_dtype (desc);
|
|
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
|
|
|
|
res_desc = gfc_evaluate_now (desc, &se->pre);
|
|
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
|
|
se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
|
|
|
|
/* Free the lhs after the function call and copy the result data to
|
|
the lhs descriptor. */
|
|
tmp = gfc_conv_descriptor_data_get (desc);
|
|
zero_cond = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_type_node, tmp,
|
|
build_int_cst (TREE_TYPE (tmp), 0));
|
|
zero_cond = gfc_evaluate_now (zero_cond, &se->post);
|
|
tmp = gfc_call_free (tmp);
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
|
|
tmp = gfc_conv_descriptor_data_get (res_desc);
|
|
gfc_conv_descriptor_data_set (&se->post, desc, tmp);
|
|
|
|
/* Check that the shapes are the same between lhs and expression.
|
|
The evaluation of the shape is done in 'shape_block' to avoid
|
|
unitialized warnings from the lhs bounds. */
|
|
not_same_shape = boolean_false_node;
|
|
gfc_start_block (&shape_block);
|
|
for (n = 0 ; n < rank; n++)
|
|
{
|
|
tree tmp1;
|
|
tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
|
|
tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type, tmp, tmp1);
|
|
tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
|
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type, tmp, tmp1);
|
|
tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type, tmp, tmp1);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node, tmp,
|
|
gfc_index_zero_node);
|
|
tmp = gfc_evaluate_now (tmp, &shape_block);
|
|
if (n == 0)
|
|
not_same_shape = tmp;
|
|
else
|
|
not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
|
|
logical_type_node, tmp,
|
|
not_same_shape);
|
|
}
|
|
|
|
/* 'zero_cond' being true is equal to lhs not being allocated or the
|
|
shapes being different. */
|
|
tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
|
|
zero_cond, not_same_shape);
|
|
gfc_add_modify (&shape_block, zero_cond, tmp);
|
|
tmp = gfc_finish_block (&shape_block);
|
|
tmp = build3_v (COND_EXPR, zero_cond,
|
|
build_empty_stmt (input_location), tmp);
|
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
|
|
/* Now reset the bounds returned from the function call to bounds based
|
|
on the lhs lbounds, except where the lhs is not allocated or the shapes
|
|
of 'variable and 'expr' are different. Set the offset accordingly. */
|
|
offset = gfc_index_zero_node;
|
|
for (n = 0 ; n < rank; n++)
|
|
{
|
|
tree lbound;
|
|
|
|
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
|
|
lbound = fold_build3_loc (input_location, COND_EXPR,
|
|
gfc_array_index_type, zero_cond,
|
|
gfc_index_one_node, lbound);
|
|
lbound = gfc_evaluate_now (lbound, &se->post);
|
|
|
|
tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
|
gfc_array_index_type, tmp, lbound);
|
|
gfc_conv_descriptor_lbound_set (&se->post, desc,
|
|
gfc_rank_cst[n], lbound);
|
|
gfc_conv_descriptor_ubound_set (&se->post, desc,
|
|
gfc_rank_cst[n], tmp);
|
|
|
|
/* Set stride and accumulate the offset. */
|
|
tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
|
|
gfc_conv_descriptor_stride_set (&se->post, desc,
|
|
gfc_rank_cst[n], tmp);
|
|
tmp = fold_build2_loc (input_location, MULT_EXPR,
|
|
gfc_array_index_type, lbound, tmp);
|
|
offset = fold_build2_loc (input_location, MINUS_EXPR,
|
|
gfc_array_index_type, offset, tmp);
|
|
offset = gfc_evaluate_now (offset, &se->post);
|
|
}
|
|
|
|
gfc_conv_descriptor_offset_set (&se->post, desc, offset);
|
|
}
|
|
|
|
|
|
|
|
/* Try to translate array(:) = func (...), where func is a transformational
|
|
array function, without using a temporary. Returns NULL if this isn't the
|
|
case. */
|
|
|
|
static tree
|
|
gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
|
|
{
|
|
gfc_se se;
|
|
gfc_ss *ss = NULL;
|
|
gfc_component *comp = NULL;
|
|
gfc_loopinfo loop;
|
|
|
|
if (arrayfunc_assign_needs_temporary (expr1, expr2))
|
|
return NULL;
|
|
|
|
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
|
|
functions. */
|
|
comp = gfc_get_proc_ptr_comp (expr2);
|
|
|
|
if (!(expr2->value.function.isym
|
|
|| (comp && comp->attr.dimension)
|
|
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
|
|
&& expr2->value.function.esym->result->attr.dimension)))
|
|
return NULL;
|
|
|
|
gfc_init_se (&se, NULL);
|
|
gfc_start_block (&se.pre);
|
|
se.want_pointer = 1;
|
|
|
|
gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
|
|
|
|
if (expr1->ts.type == BT_DERIVED
|
|
&& expr1->ts.u.derived->attr.alloc_comp)
|
|
{
|
|
tree tmp;
|
|
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
|
|
expr1->rank);
|
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
}
|
|
|
|
se.direct_byref = 1;
|
|
se.ss = gfc_walk_expr (expr2);
|
|
gcc_assert (se.ss != gfc_ss_terminator);
|
|
|
|
/* Reallocate on assignment needs the loopinfo for extrinsic functions.
|
|
This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
|
|
Clearly, this cannot be done for an allocatable function result, since
|
|
the shape of the result is unknown and, in any case, the function must
|
|
correctly take care of the reallocation internally. For intrinsic
|
|
calls, the array data is freed and the library takes care of allocation.
|
|
TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
|
|
to the library. */
|
|
if (flag_realloc_lhs
|
|
&& gfc_is_reallocatable_lhs (expr1)
|
|
&& !gfc_expr_attr (expr1).codimension
|
|
&& !gfc_is_coindexed (expr1)
|
|
&& !(expr2->value.function.esym
|
|
&& expr2->value.function.esym->result->attr.allocatable))
|
|
{
|
|
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
|
|
|
|
if (!expr2->value.function.isym)
|
|
{
|
|
ss = gfc_walk_expr (expr1);
|
|
gcc_assert (ss != gfc_ss_terminator);
|
|
|
|
realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
|
|
ss->is_alloc_lhs = 1;
|
|
}
|
|
else
|
|
fcncall_realloc_result (&se, expr1->rank);
|
|
}
|
|
|
|
gfc_conv_function_expr (&se, expr2);
|
|
gfc_add_block_to_block (&se.pre, &se.post);
|
|
|
|
if (ss)
|
|
gfc_cleanup_loop (&loop);
|
|
else
|
|
gfc_free_ss_chain (se.ss);
|
|
|
|
return gfc_finish_block (&se.pre);
|
|
}
|
|
|
|
|
|
/* Try to efficiently translate array(:) = 0. Return NULL if this
|
|
can't be done. */
|
|
|
|
static tree
|
|
gfc_trans_zero_assign (gfc_expr * expr)
|
|
{
|
|
tree dest, len, type;
|
|
tree tmp;
|
|
gfc_symbol *sym;
|
|
|
|
sym = expr->symtree->n.sym;
|
|
dest = gfc_get_symbol_decl (sym);
|
|
|
|
type = TREE_TYPE (dest);
|
|
if (POINTER_TYPE_P (type))
|
|
type = TREE_TYPE (type);
|
|
if (!GFC_ARRAY_TYPE_P (type))
|
|
return NULL_TREE;
|
|
|
|
/* Determine the length of the array. */
|
|
len = GFC_TYPE_ARRAY_SIZE (type);
|
|
if (!len || TREE_CODE (len) != INTEGER_CST)
|
|
return NULL_TREE;
|
|
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
|
|
len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
|
|
fold_convert (gfc_array_index_type, tmp));
|
|
|
|
/* If we are zeroing a local array avoid taking its address by emitting
|
|
a = {} instead. */
|
|
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
|
|
return build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
|
dest, build_constructor (TREE_TYPE (dest),
|
|
NULL));
|
|
|
|
/* Convert arguments to the correct types. */
|
|
dest = fold_convert (pvoid_type_node, dest);
|
|
len = fold_convert (size_type_node, len);
|
|
|
|
/* Construct call to __builtin_memset. */
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMSET),
|
|
3, dest, integer_zero_node, len);
|
|
return fold_convert (void_type_node, tmp);
|
|
}
|
|
|
|
|
|
/* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
|
|
that constructs the call to __builtin_memcpy. */
|
|
|
|
tree
|
|
gfc_build_memcpy_call (tree dst, tree src, tree len)
|
|
{
|
|
tree tmp;
|
|
|
|
/* Convert arguments to the correct types. */
|
|
if (!POINTER_TYPE_P (TREE_TYPE (dst)))
|
|
dst = gfc_build_addr_expr (pvoid_type_node, dst);
|
|
else
|
|
dst = fold_convert (pvoid_type_node, dst);
|
|
|
|
if (!POINTER_TYPE_P (TREE_TYPE (src)))
|
|
src = gfc_build_addr_expr (pvoid_type_node, src);
|
|
else
|
|
src = fold_convert (pvoid_type_node, src);
|
|
|
|
len = fold_convert (size_type_node, len);
|
|
|
|
/* Construct call to __builtin_memcpy. */
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MEMCPY),
|
|
3, dst, src, len);
|
|
return fold_convert (void_type_node, tmp);
|
|
}
|
|
|
|
|
|
/* Try to efficiently translate dst(:) = src(:). Return NULL if this
|
|
can't be done. EXPR1 is the destination/lhs and EXPR2 is the
|
|
source/rhs, both are gfc_full_array_ref_p which have been checked for
|
|
dependencies. */
|
|
|
|
static tree
|
|
gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
|
|
{
|
|
tree dst, dlen, dtype;
|
|
tree src, slen, stype;
|
|
tree tmp;
|
|
|
|
dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
|
|
src = gfc_get_symbol_decl (expr2->symtree->n.sym);
|
|
|
|
dtype = TREE_TYPE (dst);
|
|
if (POINTER_TYPE_P (dtype))
|
|
dtype = TREE_TYPE (dtype);
|
|
stype = TREE_TYPE (src);
|
|
if (POINTER_TYPE_P (stype))
|
|
stype = TREE_TYPE (stype);
|
|
|
|
if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
|
|
return NULL_TREE;
|
|
|
|
/* Determine the lengths of the arrays. */
|
|
dlen = GFC_TYPE_ARRAY_SIZE (dtype);
|
|
if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
|
|
return NULL_TREE;
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
|
|
dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
dlen, fold_convert (gfc_array_index_type, tmp));
|
|
|
|
slen = GFC_TYPE_ARRAY_SIZE (stype);
|
|
if (!slen || TREE_CODE (slen) != INTEGER_CST)
|
|
return NULL_TREE;
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
|
|
slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
|
slen, fold_convert (gfc_array_index_type, tmp));
|
|
|
|
/* Sanity check that they are the same. This should always be
|
|
the case, as we should already have checked for conformance. */
|
|
if (!tree_int_cst_equal (slen, dlen))
|
|
return NULL_TREE;
|
|
|
|
return gfc_build_memcpy_call (dst, src, dlen);
|
|
}
|
|
|
|
|
|
/* Try to efficiently translate array(:) = (/ ... /). Return NULL if
|
|
this can't be done. EXPR1 is the destination/lhs for which
|
|
gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
|
|
|
|
static tree
|
|
gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
|
|
{
|
|
unsigned HOST_WIDE_INT nelem;
|
|
tree dst, dtype;
|
|
tree src, stype;
|
|
tree len;
|
|
tree tmp;
|
|
|
|
nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
|
|
if (nelem == 0)
|
|
return NULL_TREE;
|
|
|
|
dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
|
|
dtype = TREE_TYPE (dst);
|
|
if (POINTER_TYPE_P (dtype))
|
|
dtype = TREE_TYPE (dtype);
|
|
if (!GFC_ARRAY_TYPE_P (dtype))
|
|
return NULL_TREE;
|
|
|
|
/* Determine the lengths of the array. */
|
|
len = GFC_TYPE_ARRAY_SIZE (dtype);
|
|
if (!len || TREE_CODE (len) != INTEGER_CST)
|
|
return NULL_TREE;
|
|
|
|
/* Confirm that the constructor is the same size. */
|
|
if (compare_tree_int (len, nelem) != 0)
|
|
return NULL_TREE;
|
|
|
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
|
|
len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
|
|
fold_convert (gfc_array_index_type, tmp));
|
|
|
|
stype = gfc_typenode_for_spec (&expr2->ts);
|
|
src = gfc_build_constant_array_constructor (expr2, stype);
|
|
|
|
return gfc_build_memcpy_call (dst, src, len);
|
|
}
|
|
|
|
|
|
/* Tells whether the expression is to be treated as a variable reference. */
|
|
|
|
bool
|
|
gfc_expr_is_variable (gfc_expr *expr)
|
|
{
|
|
gfc_expr *arg;
|
|
gfc_component *comp;
|
|
gfc_symbol *func_ifc;
|
|
|
|
if (expr->expr_type == EXPR_VARIABLE)
|
|
return true;
|
|
|
|
arg = gfc_get_noncopying_intrinsic_argument (expr);
|
|
if (arg)
|
|
{
|
|
gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
|
|
return gfc_expr_is_variable (arg);
|
|
}
|
|
|
|
/* A data-pointer-returning function should be considered as a variable
|
|
too. */
|
|
if (expr->expr_type == EXPR_FUNCTION
|
|
&& expr->ref == NULL)
|
|
{
|
|
if (expr->value.function.isym != NULL)
|
|
return false;
|
|
|
|
if (expr->value.function.esym != NULL)
|
|
{
|
|
func_ifc = expr->value.function.esym;
|
|
goto found_ifc;
|
|
}
|
|
gcc_assert (expr->symtree);
|
|
func_ifc = expr->symtree->n.sym;
|
|
goto found_ifc;
|
|
}
|
|
|
|
comp = gfc_get_proc_ptr_comp (expr);
|
|
if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
|
|
&& comp)
|
|
{
|
|
func_ifc = comp->ts.interface;
|
|
goto found_ifc;
|
|
}
|
|
|
|
if (expr->expr_type == EXPR_COMPCALL)
|
|
{
|
|
gcc_assert (!expr->value.compcall.tbp->is_generic);
|
|
func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
|
|
goto found_ifc;
|
|
}
|
|
|
|
return false;
|
|
|
|
found_ifc:
|
|
gcc_assert (func_ifc->attr.function
|
|
&& func_ifc->result != NULL);
|
|
return func_ifc->result->attr.pointer;
|
|
}
|
|
|
|
|
|
/* Is the lhs OK for automatic reallocation? */
|
|
|
|
static bool
|
|
is_scalar_reallocatable_lhs (gfc_expr *expr)
|
|
{
|
|
gfc_ref * ref;
|
|
|
|
/* An allocatable variable with no reference. */
|
|
if (expr->symtree->n.sym->attr.allocatable
|
|
&& !expr->ref)
|
|
return true;
|
|
|
|
/* 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)
|
|
return false;
|
|
|
|
/* Find an allocatable component ref last. */
|
|
for (ref = expr->ref; ref; ref = ref->next)
|
|
if (ref->type == REF_COMPONENT
|
|
&& !ref->next
|
|
&& ref->u.c.component->attr.allocatable)
|
|
return true;
|
|
|
|
return false;
|
|
}
|
|
|
|
|
|
/* Allocate or reallocate scalar lhs, as necessary. */
|
|
|
|
static void
|
|
alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
|
|
tree string_length,
|
|
gfc_expr *expr1,
|
|
gfc_expr *expr2)
|
|
|
|
{
|
|
tree cond;
|
|
tree tmp;
|
|
tree size;
|
|
tree size_in_bytes;
|
|
tree jump_label1;
|
|
tree jump_label2;
|
|
gfc_se lse;
|
|
gfc_ref *ref;
|
|
|
|
if (!expr1 || expr1->rank)
|
|
return;
|
|
|
|
if (!expr2 || expr2->rank)
|
|
return;
|
|
|
|
for (ref = expr1->ref; ref; ref = ref->next)
|
|
if (ref->type == REF_SUBSTRING)
|
|
return;
|
|
|
|
realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
|
|
|
|
/* Since this is a scalar lhs, we can afford to do this. That is,
|
|
there is no risk of side effects being repeated. */
|
|
gfc_init_se (&lse, NULL);
|
|
lse.want_pointer = 1;
|
|
gfc_conv_expr (&lse, expr1);
|
|
|
|
jump_label1 = gfc_build_label_decl (NULL_TREE);
|
|
jump_label2 = gfc_build_label_decl (NULL_TREE);
|
|
|
|
/* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
|
|
tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
|
|
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
|
|
lse.expr, tmp);
|
|
tmp = build3_v (COND_EXPR, cond,
|
|
build1_v (GOTO_EXPR, jump_label1),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (block, tmp);
|
|
|
|
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
|
|
{
|
|
/* Use the rhs string length and the lhs element size. */
|
|
size = string_length;
|
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
|
|
tmp = TYPE_SIZE_UNIT (tmp);
|
|
size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
|
|
TREE_TYPE (tmp), tmp,
|
|
fold_convert (TREE_TYPE (tmp), size));
|
|
}
|
|
else
|
|
{
|
|
/* Otherwise use the length in bytes of the rhs. */
|
|
size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
|
|
size_in_bytes = size;
|
|
}
|
|
|
|
size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
|
|
size_in_bytes, size_one_node);
|
|
|
|
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),
|
|
2, build_one_cst (size_type_node),
|
|
size_in_bytes);
|
|
tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
|
|
gfc_add_modify (block, lse.expr, tmp);
|
|
}
|
|
else
|
|
{
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_MALLOC),
|
|
1, size_in_bytes);
|
|
tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
|
|
gfc_add_modify (block, lse.expr, tmp);
|
|
}
|
|
|
|
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
|
|
{
|
|
/* Deferred characters need checking for lhs and rhs string
|
|
length. Other deferred parameter variables will have to
|
|
come here too. */
|
|
tmp = build1_v (GOTO_EXPR, jump_label2);
|
|
gfc_add_expr_to_block (block, tmp);
|
|
}
|
|
tmp = build1_v (LABEL_EXPR, jump_label1);
|
|
gfc_add_expr_to_block (block, tmp);
|
|
|
|
/* For a deferred length character, reallocate if lengths of lhs and
|
|
rhs are different. */
|
|
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
|
|
{
|
|
cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
|
|
lse.string_length,
|
|
fold_convert (TREE_TYPE (lse.string_length),
|
|
size));
|
|
/* Jump past the realloc if the lengths are the same. */
|
|
tmp = build3_v (COND_EXPR, cond,
|
|
build1_v (GOTO_EXPR, jump_label2),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (block, tmp);
|
|
tmp = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_REALLOC),
|
|
2, fold_convert (pvoid_type_node, lse.expr),
|
|
size_in_bytes);
|
|
tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
|
|
gfc_add_modify (block, lse.expr, tmp);
|
|
tmp = build1_v (LABEL_EXPR, jump_label2);
|
|
gfc_add_expr_to_block (block, tmp);
|
|
|
|
/* Update the lhs character length. */
|
|
size = string_length;
|
|
gfc_add_modify (block, lse.string_length,
|
|
fold_convert (TREE_TYPE (lse.string_length), size));
|
|
}
|
|
}
|
|
|
|
/* Check for assignments of the type
|
|
|
|
a = a + 4
|
|
|
|
to make sure we do not check for reallocation unneccessarily. */
|
|
|
|
|
|
static bool
|
|
is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
|
|
{
|
|
gfc_actual_arglist *a;
|
|
gfc_expr *e1, *e2;
|
|
|
|
switch (expr2->expr_type)
|
|
{
|
|
case EXPR_VARIABLE:
|
|
return gfc_dep_compare_expr (expr1, expr2) == 0;
|
|
|
|
case EXPR_FUNCTION:
|
|
if (expr2->value.function.esym
|
|
&& expr2->value.function.esym->attr.elemental)
|
|
{
|
|
for (a = expr2->value.function.actual; a != NULL; a = a->next)
|
|
{
|
|
e1 = a->expr;
|
|
if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
|
|
return false;
|
|
}
|
|
return true;
|
|
}
|
|
else if (expr2->value.function.isym
|
|
&& expr2->value.function.isym->elemental)
|
|
{
|
|
for (a = expr2->value.function.actual; a != NULL; a = a->next)
|
|
{
|
|
e1 = a->expr;
|
|
if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
|
|
return false;
|
|
}
|
|
return true;
|
|
}
|
|
|
|
break;
|
|
|
|
case EXPR_OP:
|
|
switch (expr2->value.op.op)
|
|
{
|
|
case INTRINSIC_NOT:
|
|
case INTRINSIC_UPLUS:
|
|
case INTRINSIC_UMINUS:
|
|
case INTRINSIC_PARENTHESES:
|
|
return is_runtime_conformable (expr1, expr2->value.op.op1);
|
|
|
|
case INTRINSIC_PLUS:
|
|
case INTRINSIC_MINUS:
|
|
case INTRINSIC_TIMES:
|
|
case INTRINSIC_DIVIDE:
|
|
case INTRINSIC_POWER:
|
|
case INTRINSIC_AND:
|
|
case INTRINSIC_OR:
|
|
case INTRINSIC_EQV:
|
|
case INTRINSIC_NEQV:
|
|
case INTRINSIC_EQ:
|
|
case INTRINSIC_NE:
|
|
case INTRINSIC_GT:
|
|
case INTRINSIC_GE:
|
|
case INTRINSIC_LT:
|
|
case INTRINSIC_LE:
|
|
case INTRINSIC_EQ_OS:
|
|
case INTRINSIC_NE_OS:
|
|
case INTRINSIC_GT_OS:
|
|
case INTRINSIC_GE_OS:
|
|
case INTRINSIC_LT_OS:
|
|
case INTRINSIC_LE_OS:
|
|
|
|
e1 = expr2->value.op.op1;
|
|
e2 = expr2->value.op.op2;
|
|
|
|
if (e1->rank == 0 && e2->rank > 0)
|
|
return is_runtime_conformable (expr1, e2);
|
|
else if (e1->rank > 0 && e2->rank == 0)
|
|
return is_runtime_conformable (expr1, e1);
|
|
else if (e1->rank > 0 && e2->rank > 0)
|
|
return is_runtime_conformable (expr1, e1)
|
|
&& is_runtime_conformable (expr1, e2);
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
|
|
}
|
|
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
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, old_vptr;
|
|
vec<tree, va_gc> *args = NULL;
|
|
|
|
/* Store the old vptr so that dynamic types can be compared for
|
|
reallocation to occur or not. */
|
|
if (class_realloc)
|
|
{
|
|
tmp = lse->expr;
|
|
if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|
|
tmp = gfc_get_class_from_expr (tmp);
|
|
}
|
|
|
|
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
|
|
&from_len);
|
|
|
|
/* Generate (re)allocation of the lhs. */
|
|
if (class_realloc)
|
|
{
|
|
stmtblock_t alloc, re_alloc;
|
|
tree class_han, re, size;
|
|
|
|
if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|
|
old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
|
|
else
|
|
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
|
|
|
|
size = gfc_vptr_size_get (vptr);
|
|
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
|
|
? gfc_class_data_get (lse->expr) : lse->expr;
|
|
|
|
/* Allocate block. */
|
|
gfc_init_block (&alloc);
|
|
gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
|
|
|
|
/* Reallocate if dynamic types are different. */
|
|
gfc_init_block (&re_alloc);
|
|
re = build_call_expr_loc (input_location,
|
|
builtin_decl_explicit (BUILT_IN_REALLOC), 2,
|
|
fold_convert (pvoid_type_node, class_han),
|
|
size);
|
|
tmp = fold_build2_loc (input_location, NE_EXPR,
|
|
logical_type_node, vptr, old_vptr);
|
|
re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
|
tmp, re, build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (&re_alloc, re);
|
|
|
|
/* Allocate if _data is NULL, reallocate otherwise. */
|
|
tmp = fold_build2_loc (input_location, EQ_EXPR,
|
|
logical_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),
|
|
gfc_finish_block (&re_alloc));
|
|
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,
|
|
logical_type_node, from_len,
|
|
build_zero_cst (TREE_TYPE (from_len)));
|
|
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).
|
|
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 use_vptr_copy, bool may_alias)
|
|
{
|
|
gfc_se lse;
|
|
gfc_se rse;
|
|
gfc_ss *lss;
|
|
gfc_ss *lss_section;
|
|
gfc_ss *rss;
|
|
gfc_loopinfo loop;
|
|
tree tmp;
|
|
stmtblock_t block;
|
|
stmtblock_t body;
|
|
bool l_is_temp;
|
|
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;
|
|
bool realloc_flag;
|
|
|
|
/* Assignment of the form lhs = rhs. */
|
|
gfc_start_block (&block);
|
|
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
|
|
/* Walk the lhs. */
|
|
lss = gfc_walk_expr (expr1);
|
|
if (gfc_is_reallocatable_lhs (expr1))
|
|
{
|
|
lss->no_bounds_check = 1;
|
|
if (!(expr2->expr_type == EXPR_FUNCTION
|
|
&& expr2->value.function.isym != NULL
|
|
&& !(expr2->value.function.isym->elemental
|
|
|| expr2->value.function.isym->conversion)))
|
|
lss->is_alloc_lhs = 1;
|
|
}
|
|
else
|
|
lss->no_bounds_check = expr1->no_bounds_check;
|
|
|
|
rss = NULL;
|
|
|
|
if ((expr1->ts.type == BT_DERIVED)
|
|
&& (gfc_is_class_array_function (expr2)
|
|
|| 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))
|
|
&& lhs_attr.flavor != FL_PROCEDURE;
|
|
|
|
realloc_flag = flag_realloc_lhs
|
|
&& gfc_is_reallocatable_lhs (expr1)
|
|
&& expr2->rank
|
|
&& !is_runtime_conformable (expr1, 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. */
|
|
lss_section = lss;
|
|
|
|
/* Find a non-scalar SS from the lhs. */
|
|
while (lss_section != gfc_ss_terminator
|
|
&& lss_section->info->type != GFC_SS_SECTION)
|
|
lss_section = lss_section->next;
|
|
|
|
gcc_assert (lss_section != gfc_ss_terminator);
|
|
|
|
/* Initialize the scalarizer. */
|
|
gfc_init_loopinfo (&loop);
|
|
|
|
/* Walk the rhs. */
|
|
rss = gfc_walk_expr (expr2);
|
|
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;
|
|
|
|
rss->no_bounds_check = expr2->no_bounds_check;
|
|
/* Associate the SS with the loop. */
|
|
gfc_add_ss_to_loop (&loop, lss);
|
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
|
/* Calculate the bounds of the scalarization. */
|
|
gfc_conv_ss_startstride (&loop);
|
|
/* Enable loop reversal. */
|
|
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
|
|
loop.reverse[n] = GFC_ENABLE_REVERSE;
|
|
/* Resolve any data dependencies in the statement. */
|
|
if (may_alias)
|
|
gfc_conv_resolve_dependencies (&loop, lss, rss);
|
|
/* Setup the scalarizing loops. */
|
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
|
|
|
/* Setup the gfc_se structures. */
|
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
|
rse.ss = rss;
|
|
gfc_mark_ss_chain_used (rss, 1);
|
|
if (loop.temp_ss == NULL)
|
|
{
|
|
lse.ss = lss;
|
|
gfc_mark_ss_chain_used (lss, 1);
|
|
}
|
|
else
|
|
{
|
|
lse.ss = loop.temp_ss;
|
|
gfc_mark_ss_chain_used (lss, 3);
|
|
gfc_mark_ss_chain_used (loop.temp_ss, 3);
|
|
}
|
|
|
|
/* Allow the scalarizer to workshare array assignments. */
|
|
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);
|
|
}
|
|
else
|
|
gfc_init_block (&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. */
|
|
if (gfc_is_alloc_class_scalar_function (expr2)
|
|
&& expr1->ts.type == BT_DERIVED)
|
|
{
|
|
rse.expr = gfc_class_data_get (rse.expr);
|
|
rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
|
|
}
|
|
|
|
/* Stabilize a string length for temporaries. */
|
|
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)
|
|
{
|
|
if (expr1->ts.deferred
|
|
&& gfc_expr_attr (expr1).allocatable
|
|
&& gfc_check_dependency (expr1, expr2, true))
|
|
rse.string_length =
|
|
gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
|
|
string_length = rse.string_length;
|
|
}
|
|
else
|
|
string_length = NULL_TREE;
|
|
|
|
if (l_is_temp)
|
|
{
|
|
gfc_conv_tmp_array_ref (&lse);
|
|
if (expr2->ts.type == BT_CHARACTER)
|
|
lse.string_length = string_length;
|
|
}
|
|
else
|
|
{
|
|
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;
|
|
STRIP_NOPS (tmp);
|
|
|
|
/* 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, logical_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);
|
|
}
|
|
|
|
/* Deallocate the lhs parameterized components if required. */
|
|
if (dealloc && expr2->expr_type == EXPR_FUNCTION
|
|
&& !expr1->symtree->n.sym->attr.associate_var)
|
|
{
|
|
if (expr1->ts.type == BT_DERIVED
|
|
&& expr1->ts.u.derived
|
|
&& expr1->ts.u.derived->attr.pdt_type)
|
|
{
|
|
tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
|
|
expr1->rank);
|
|
gfc_add_expr_to_block (&lse.pre, tmp);
|
|
}
|
|
else if (expr1->ts.type == BT_CLASS
|
|
&& CLASS_DATA (expr1)->ts.u.derived
|
|
&& CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
|
|
{
|
|
tmp = gfc_class_data_get (lse.expr);
|
|
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
|
|
tmp, expr1->rank);
|
|
gfc_add_expr_to_block (&lse.pre, tmp);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* 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
|
|
&& !gfc_expr_is_variable (expr2)
|
|
&& expr1->rank && !expr2->rank);
|
|
scalar_to_array |= (expr1->ts.type == BT_DERIVED
|
|
&& expr1->rank
|
|
&& expr1->ts.u.derived->attr.alloc_comp
|
|
&& gfc_is_alloc_class_scalar_function (expr2));
|
|
if (scalar_to_array && dealloc)
|
|
{
|
|
tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
|
|
gfc_prepend_expr_to_block (&loop.post, tmp);
|
|
}
|
|
|
|
/* When assigning a character function result to a deferred-length variable,
|
|
the function call must happen before the (re)allocation of the lhs -
|
|
otherwise the character length of the result is not known.
|
|
NOTE 1: This relies on having the exact dependence of the length type
|
|
parameter available to the caller; gfortran saves it in the .mod files.
|
|
NOTE 2: Vector array references generate an index temporary that must
|
|
not go outside the loop. Otherwise, variables should not generate
|
|
a pre block.
|
|
NOTE 3: The concatenation operation generates a temporary pointer,
|
|
whose allocation must go to the innermost loop.
|
|
NOTE 4: Elemental functions may generate a temporary, too. */
|
|
if (flag_realloc_lhs
|
|
&& expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
|
|
&& !(lss != gfc_ss_terminator
|
|
&& rss != gfc_ss_terminator
|
|
&& ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
|
|
|| (expr2->expr_type == EXPR_FUNCTION
|
|
&& expr2->value.function.esym != NULL
|
|
&& expr2->value.function.esym->attr.elemental)
|
|
|| (expr2->expr_type == EXPR_FUNCTION
|
|
&& expr2->value.function.isym != NULL
|
|
&& expr2->value.function.isym->elemental)
|
|
|| (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
|
|
derived type, so that the finalization of the function result does not
|
|
affect the lhs of the assignment. Prepend is used to ensure that the
|
|
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_class_array_function (expr2)
|
|
|| gfc_is_alloc_class_scalar_function (expr2)))
|
|
{
|
|
tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
|
|
gfc_prepend_expr_to_block (&rse.post, tmp);
|
|
if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
|
|
gfc_add_block_to_block (&loop.post, &rse.post);
|
|
}
|
|
|
|
tmp = NULL_TREE;
|
|
|
|
if (is_poly_assign)
|
|
{
|
|
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
|
|
use_vptr_copy || (lhs_attr.allocatable
|
|
&& !lhs_attr.dimension),
|
|
!realloc_flag && flag_realloc_lhs
|
|
&& !lhs_attr.pointer);
|
|
if (expr2->expr_type == EXPR_FUNCTION
|
|
&& expr2->ts.type == BT_DERIVED
|
|
&& expr2->ts.u.derived->attr.alloc_comp)
|
|
{
|
|
tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
|
|
rse.expr, expr2->rank);
|
|
if (lss == gfc_ss_terminator)
|
|
gfc_add_expr_to_block (&rse.post, tmp2);
|
|
else
|
|
gfc_add_expr_to_block (&loop.post, tmp2);
|
|
}
|
|
}
|
|
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 if (!is_poly_assign && expr2->must_finalize
|
|
&& expr1->ts.type == BT_CLASS
|
|
&& expr2->ts.type == BT_CLASS)
|
|
{
|
|
/* This case comes about when the scalarizer provides array element
|
|
references. Use the vptr copy function, since this does a deep
|
|
copy of allocatable components, without which the finalizer call
|
|
will deallocate the components. */
|
|
tmp = gfc_get_vptr_from_expr (rse.expr);
|
|
if (tmp != NULL_TREE)
|
|
{
|
|
tree fcn = gfc_vptr_copy_get (tmp);
|
|
if (POINTER_TYPE_P (TREE_TYPE (fcn)))
|
|
fcn = build_fold_indirect_ref_loc (input_location, fcn);
|
|
tmp = build_call_expr_loc (input_location,
|
|
fcn, 2,
|
|
gfc_build_addr_expr (NULL, rse.expr),
|
|
gfc_build_addr_expr (NULL, lse.expr));
|
|
}
|
|
}
|
|
|
|
/* If nothing else works, do it the old fashioned way! */
|
|
if (tmp == NULL_TREE)
|
|
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)
|
|
&& !is_poly_assign)
|
|
alloc_scalar_allocatable_for_assignment (&block, string_length,
|
|
expr1, expr2);
|
|
|
|
/* Use the scalar assignment as is. */
|
|
gfc_add_block_to_block (&block, &body);
|
|
}
|
|
else
|
|
{
|
|
gcc_assert (lse.ss == gfc_ss_terminator
|
|
&& rse.ss == gfc_ss_terminator);
|
|
|
|
if (l_is_temp)
|
|
{
|
|
gfc_trans_scalarized_loop_boundary (&loop, &body);
|
|
|
|
/* We need to copy the temporary to the actual lhs. */
|
|
gfc_init_se (&lse, NULL);
|
|
gfc_init_se (&rse, NULL);
|
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
|
rse.ss = loop.temp_ss;
|
|
lse.ss = lss;
|
|
|
|
gfc_conv_tmp_array_ref (&rse);
|
|
gfc_conv_expr (&lse, expr1);
|
|
|
|
gcc_assert (lse.ss == gfc_ss_terminator
|
|
&& rse.ss == gfc_ss_terminator);
|
|
|
|
if (expr2->ts.type == BT_CHARACTER)
|
|
rse.string_length = string_length;
|
|
|
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
|
|
false, dealloc);
|
|
gfc_add_expr_to_block (&body, tmp);
|
|
}
|
|
|
|
/* F2003: Allocate or reallocate lhs of allocatable array. */
|
|
if (realloc_flag)
|
|
{
|
|
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
|
|
ompws_flags &= ~OMPWS_SCALARIZER_WS;
|
|
tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
|
|
if (tmp != NULL_TREE)
|
|
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);
|
|
|
|
/* Wrap the whole thing up. */
|
|
gfc_add_block_to_block (&block, &loop.pre);
|
|
gfc_add_block_to_block (&block, &loop.post);
|
|
|
|
gfc_cleanup_loop (&loop);
|
|
}
|
|
|
|
return gfc_finish_block (&block);
|
|
}
|
|
|
|
|
|
/* Check whether EXPR is a copyable array. */
|
|
|
|
static bool
|
|
copyable_array_p (gfc_expr * expr)
|
|
{
|
|
if (expr->expr_type != EXPR_VARIABLE)
|
|
return false;
|
|
|
|
/* First check it's an array. */
|
|
if (expr->rank < 1 || !expr->ref || expr->ref->next)
|
|
return false;
|
|
|
|
if (!gfc_full_array_ref_p (expr->ref, NULL))
|
|
return false;
|
|
|
|
/* Next check that it's of a simple enough type. */
|
|
switch (expr->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
case BT_REAL:
|
|
case BT_COMPLEX:
|
|
case BT_LOGICAL:
|
|
return true;
|
|
|
|
case BT_CHARACTER:
|
|
return false;
|
|
|
|
case_bt_struct:
|
|
return !expr->ts.u.derived->attr.alloc_comp;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
|
|
return false;
|
|
}
|
|
|
|
/* Translate an assignment. */
|
|
|
|
tree
|
|
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|
|
bool dealloc, bool use_vptr_copy, bool may_alias)
|
|
{
|
|
tree tmp;
|
|
|
|
/* Special case a single function returning an array. */
|
|
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
|
|
{
|
|
tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
|
|
if (tmp)
|
|
return tmp;
|
|
}
|
|
|
|
/* Special case assigning an array to zero. */
|
|
if (copyable_array_p (expr1)
|
|
&& is_zero_initializer_p (expr2))
|
|
{
|
|
tmp = gfc_trans_zero_assign (expr1);
|
|
if (tmp)
|
|
return tmp;
|
|
}
|
|
|
|
/* Special case copying one array to another. */
|
|
if (copyable_array_p (expr1)
|
|
&& copyable_array_p (expr2)
|
|
&& gfc_compare_types (&expr1->ts, &expr2->ts)
|
|
&& !gfc_check_dependency (expr1, expr2, 0))
|
|
{
|
|
tmp = gfc_trans_array_copy (expr1, expr2);
|
|
if (tmp)
|
|
return tmp;
|
|
}
|
|
|
|
/* Special case initializing an array from a constant array constructor. */
|
|
if (copyable_array_p (expr1)
|
|
&& expr2->expr_type == EXPR_ARRAY
|
|
&& gfc_compare_types (&expr1->ts, &expr2->ts))
|
|
{
|
|
tmp = gfc_trans_array_constructor_copy (expr1, expr2);
|
|
if (tmp)
|
|
return tmp;
|
|
}
|
|
|
|
if (UNLIMITED_POLY (expr1) && expr1->rank)
|
|
use_vptr_copy = true;
|
|
|
|
/* Fallback to the scalarizer to generate explicit loops. */
|
|
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, true);
|
|
}
|
|
|
|
tree
|
|
gfc_trans_assign (gfc_code * code)
|
|
{
|
|
return gfc_trans_assignment (code->expr1, code->expr2, false, true);
|
|
}
|
|
|
|
/* Generate a simple loop for internal use of the form
|
|
for (var = begin; var <cond> end; var += step)
|
|
body; */
|
|
void
|
|
gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
|
|
enum tree_code cond, tree step, tree body)
|
|
{
|
|
tree tmp;
|
|
|
|
/* var = begin. */
|
|
gfc_add_modify (block, var, begin);
|
|
|
|
/* Loop: for (var = begin; var <cond> end; var += step). */
|
|
tree label_loop = gfc_build_label_decl (NULL_TREE);
|
|
tree label_cond = gfc_build_label_decl (NULL_TREE);
|
|
TREE_USED (label_loop) = 1;
|
|
TREE_USED (label_cond) = 1;
|
|
|
|
gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
|
|
gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
|
|
|
|
/* Loop body. */
|
|
gfc_add_expr_to_block (block, body);
|
|
|
|
/* End of loop body. */
|
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
|
|
gfc_add_modify (block, var, tmp);
|
|
gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
|
|
tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
|
|
tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
|
|
build_empty_stmt (input_location));
|
|
gfc_add_expr_to_block (block, tmp);
|
|
}
|