Google Git
Sign in
gnu / gcc / refs/heads/releases/gcc-4.8 / . / gcc / fortran / trans-expr.c
blob: 456b2ceadff3ccccfe276e42a5a1c0ab72815e9a [file] [log] [blame]
/* Expression translation
Copyright (C) 2002-2013 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.c-- generate GENERIC trees for gfc_expr. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "diagnostic-core.h" /* For fatal_error. */
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
#include "constructor.h"
#include "trans.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"
/* 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;
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;
type = get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (type));
gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
/* 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 && POINTER_TYPE_P (TREE_TYPE (scalar)))
gfc_add_modify (&se->post, scalar,
fold_convert (TREE_TYPE (scalar),
gfc_conv_descriptor_data_get (desc)));
return desc;
}
/* 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 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
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;
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);
}
static tree
gfc_vtable_field_get (tree decl, int field)
{
tree size;
tree vptr;
vptr = gfc_class_vptr_get (decl);
vptr = build_fold_indirect_ref_loc (input_location, vptr);
size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
field);
size = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (size), vptr, size,
NULL_TREE);
/* Always return size as an array index type. */
if (field == VTABLE_SIZE_FIELD)
size = fold_convert (gfc_array_index_type, size);
gcc_assert (size);
return size;
}
tree
gfc_vtable_hash_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD);
}
tree
gfc_vtable_size_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD);
}
tree
gfc_vtable_extends_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD);
}
tree
gfc_vtable_def_init_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD);
}
tree
gfc_vtable_copy_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD);
}
tree
gfc_vtable_final_get (tree decl)
{
return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD);
}
#undef CLASS_DATA_FIELD
#undef CLASS_VPTR_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
/* 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;
tree type;
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
{
type = TREE_TYPE (tmp);
while (type)
{
if (GFC_CLASS_TYPE_P (type))
return gfc_class_vptr_get (tmp);
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
type = NULL_TREE;
}
if (TREE_CODE (tmp) == VAR_DECL)
break;
}
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. */
void
gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_typespec class_ts, tree vptr, bool optional,
bool optional_alloc_ptr)
{
gfc_symbol *vtab;
tree cond_optional = NULL_TREE;
gfc_ss *ss;
tree ctree;
tree var;
tree tmp;
/* 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->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);
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);
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e);
if (e->rank != class_ts.u.derived->components->as->rank)
{
gcc_assert (class_ts.u.derived->components->as->type
== AS_ASSUMED_RANK);
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);
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);
}
}
/* 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;
/* 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_intrinsic_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);
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
parmse->ss = ss;
gfc_conv_expr_descriptor (parmse, e);
gfc_add_modify (&parmse->pre, ctree, parmse->expr);
}
}
/* 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;
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)
&& (!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 (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;
}
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);
vptr = gfc_class_vptr_get (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));
if (optional)
{
tree tmp2;
cond = gfc_conv_expr_present (e->symtree->n.sym);
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. */
tree
gfc_get_class_array_ref (tree index, tree class_decl)
{
tree data = gfc_class_data_get (class_decl);
tree size = gfc_vtable_size_get (class_decl);
tree offset = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
index, size);
tree ptr;
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)
{
tree fcn;
tree fcn_type;
tree from_data;
tree to_data;
tree to_ref;
tree from_ref;
vec<tree, va_gc> *args;
tree tmp;
tree index;
stmtblock_t loopbody;
stmtblock_t body;
gfc_loopinfo loop;
args = NULL;
if (from != NULL_TREE)
fcn = gfc_vtable_copy_get (from);
else
fcn = gfc_vtable_copy_get (to);
fcn_type = TREE_TYPE (TREE_TYPE (fcn));
if (from != NULL_TREE)
from_data = gfc_class_data_get (from);
else
from_data = gfc_vtable_def_init_get (to);
to_data = gfc_class_data_get (to);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
{
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 (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
{
from_ref = gfc_get_class_array_ref (index, from);
vec_safe_push (args, from_ref);
}
else
vec_safe_push (args, from_data);
to_ref = gfc_get_class_array_ref (index, to);
vec_safe_push (args, to_ref);
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_add_block_to_block (&body, &loop.pre);
tmp = gfc_finish_block (&body);
gfc_cleanup_loop (&loop);
}
else
{
gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
vec_safe_push (args, from_data);
vec_safe_push (args, to_data);
tmp = build_call_vec (fcn_type, fcn, args);
}
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 ();
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, 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;
ppc_code->op = EXEC_CALL;
/* 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);
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);
gfc_add_data_component (lhs);
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);
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
else
{
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 (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);
}
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
tree
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
gfc_expr *lhs;
gfc_expr *rhs;
gfc_ref *ref;
gfc_start_block (&block);
ref = expr1->ref;
while (ref && ref->next)
ref = ref->next;
/* Class valued proc_pointer assignments do not need any further
preparation. */
if (ref && ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& expr2->expr_type == EXPR_VARIABLE
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& op == EXEC_POINTER_ASSIGN)
goto assign;
if (expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '_vptr' field. */
gfc_symbol *vtab = NULL;
gfc_symtree *st;
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
if (UNLIMITED_POLY (expr1)
&& expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
{
rhs = gfc_get_null_expr (&expr2->where);
goto assign_vptr;
}
if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
else
vtab = gfc_find_intrinsic_vtab (&expr2->ts);
gcc_assert (vtab);
rhs = gfc_get_expr ();
rhs->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
rhs->symtree = st;
rhs->ts = vtab->ts;
assign_vptr:
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
{
/* F2003:C717 only sequence and bind-C types can come here. */
gcc_assert (expr1->ts.u.derived->attr.sequence
|| expr1->ts.u.derived->attr.is_bind_c);
gfc_add_data_component (expr2);
goto assign;
}
else if (CLASS_DATA (expr2)->attr.dimension)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
rhs = gfc_copy_expr (expr2);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS
&& !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
else
gfc_add_data_component (expr1);
assign:
if (op == EXEC_ASSIGN)
tmp = gfc_trans_assignment (expr1, expr2, false, true);
else if (op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* End of prototype trans-class.c */
static void
realloc_lhs_warning (bt type, bool array, locus *where)
{
if (array && type != BT_CLASS && type != BT_DERIVED
&& gfc_option.warn_realloc_lhs)
gfc_warning ("Code for reallocating the allocatable array at %L will "
"be added", where);
else if (gfc_option.warn_realloc_lhs_all)
gfc_warning ("Code for reallocating the allocatable variable at %L "
"will be added", where);
}
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
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 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)
{
tree decl, cond;
gcc_assert (sym->attr.dummy);
decl = gfc_get_symbol_decl (sym);
if (TREE_CODE (decl) != PARM_DECL)
{
/* Array parameters use a temporary descriptor, we want the real
parameter. */
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, boolean_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 futher that BT_CLASS always uses an
array descriptor for arrays, also for explicit-shape/assumed-size. */
if (!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, boolean_type_node, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_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;
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;
default:
/* We should never got substring references here. These will be
broken down by the scalarizer. */
gcc_unreachable ();
break;
}
}
gcc_assert (length != NULL);
return length;
}
/* Return for an expression the backend decl of the coarray. */
static tree
get_tree_for_caf_expr (gfc_expr *expr)
{
tree caf_decl = NULL_TREE;
gfc_ref *ref;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
if (expr->symtree->n.sym->attr.codimension)
caf_decl = expr->symtree->n.sym->backend_decl;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
{
gfc_component *comp = ref->u.c.component;
if (comp->attr.pointer || comp->attr.allocatable)
caf_decl = NULL_TREE;
if (comp->attr.codimension)
caf_decl = comp->backend_decl;
}
gcc_assert (caf_decl != NULL_TREE);
return caf_decl;
}
/* 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. */
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
&& TREE_CODE (cl->backend_decl) == VAR_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;
gcc_assert (expr);
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_int_cst (gfc_charlen_type_node, 0));
gfc_add_block_to_block (pblock, &se.pre);
if (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;
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 (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
tmp = build_fold_indirect_ref_loc (input_location,
se->expr);
tmp = gfc_build_array_ref (tmp, start.expr, NULL);
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)
{
tree nonempty = fold_build2_loc (input_location, LE_EXPR,
boolean_type_node, start.expr,
end.expr);
/* Check lower bound. */
fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
start.expr,
build_int_cst (gfc_charlen_type_node, 1));
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_type_node, nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
"is less than one", name);
else
asprintf (&msg, "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, boolean_type_node,
end.expr, se->string_length);
fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
boolean_type_node, nonempty, fault);
if (name)
asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
"exceeds string length (%%ld)", name);
else
asprintf (&msg, "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);
}
/* If the start and end expressions are equal, the length is one. */
if (ref->u.ss.end
&& gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
tmp = build_int_cst (gfc_charlen_type_node, 1);
else
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
end.expr, 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. */
static void
gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
{
gfc_component *c;
tree tmp;
tree decl;
tree field;
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;
/* 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. */
if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
{
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;
}
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);
se->expr = tmp;
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
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 (((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. */
static 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 the parent type. */
for (cmp = dt->components; cmp; cmp = cmp->next)
if (strcmp (c->name, cmp->name) == 0)
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);
}
/* 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;
sym = expr->symtree->n.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;
for (ref = ss_info->data.array.ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
break;
}
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. */
else if (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. Since 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->attr.dummy
|| sym->attr.function
|| sym->attr.result))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
else if (!sym->attr.value)
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension
&& !(sym->attr.codimension && sym->attr.allocatable))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Dereference scalar hidden result. */
if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
&& (sym->attr.function || sym->attr.result)
&& !sym->attr.dimension && !sym->attr.pointer
&& !sym->attr.always_explicit)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
if ((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))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
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);
}
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, sym, &expr->where);
/* Return a pointer to an element. */
break;
case REF_COMPONENT:
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;
default:
gcc_unreachable ();
break;
}
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.c. */
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;
/* If exponent is too large, we won't expand it anyway, so don't bother
with large integer values. */
if (!TREE_INT_CST (rhs).fits_shwi ())
return 0;
m = TREE_INT_CST (rhs).to_shwi ();
/* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
of the asymmetric range of the integer type. */
n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
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, boolean_type_node,
lhs, build_int_cst (TREE_TYPE (lhs), -1));
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_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,
boolean_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;
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,
gfc_charlen_type_node, len,
build_int_cst (gfc_charlen_type_node, 1));
tmp = build_range_type (gfc_array_index_type, gfc_index_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");
tmp = gfc_call_malloc (&se->pre, type,
fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (len), len,
fold_convert (TREE_TYPE (len),
TYPE_SIZE (type))));
gfc_add_modify (&se->pre, var, tmp);
/* Free the temporary afterwards. */
tmp = gfc_call_free (convert (pvoid_type_node, 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,
TREE_TYPE (lse.string_length),
lse.string_length, 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)
&& gfc_option.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 = TRUTH_ANDIF_EXPR;
lop = 1;
break;
case INTRINSIC_OR:
code = TRUTH_ORIF_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 ("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 boolean_type_node. */
tmp = fold_build2_loc (input_location, code, boolean_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
|| !INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
|| !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;
}
void
gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
{
if (sym->backend_decl)
{
/* This becomes the nominal_type in
function.c:assign_parm_find_data_types. */
TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
/* This becomes the passed_type in
function.c:assign_parm_find_data_types. C promotes char to
integer for argument passing. */
DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
DECL_BY_REFERENCE (sym->backend_decl) = 0;
}
if (expr != NULL)
{
/* If we have a constant character expression, make it into an
integer. */
if ((*expr)->expr_type == EXPR_CONSTANT)
{
gfc_typespec ts;
gfc_clear_ts (&ts);
*expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
(int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind)
{
/* The expr needs to be compatible with a C int. If the
conversion fails, then the 2 causes an ICE. */
ts.type = BT_INTEGER;
ts.kind = gfc_c_int_kind;
gfc_convert_type (*expr, &ts, 2);
}
}
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_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 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;
}
/* 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;
}
/* 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 (TREE_CODE (base_object) != VAR_DECL)
{
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)
{
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);
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 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);</