blob: 11df1863badfa7a22846b5992426aa583bdb1a98 [file] [log] [blame]
/* Statement translation -- generate GCC trees from gfc_code.
Copyright (C) 2002-2021 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/>. */
#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 "fold-const.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
typedef struct iter_info
{
tree var;
tree start;
tree end;
tree step;
struct iter_info *next;
}
iter_info;
typedef struct forall_info
{
iter_info *this_loop;
tree mask;
tree maskindex;
int nvar;
tree size;
struct forall_info *prev_nest;
bool do_concurrent;
}
forall_info;
static void gfc_trans_where_2 (gfc_code *, tree, bool,
forall_info *, stmtblock_t *);
/* Translate a F95 label number to a LABEL_EXPR. */
tree
gfc_trans_label_here (gfc_code * code)
{
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}
/* Given a variable expression which has been ASSIGNed to, find the decl
containing the auxiliary variables. For variables in common blocks this
is a field_decl. */
void
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
{
gcc_assert (expr->symtree->n.sym->attr.assign == 1);
gfc_conv_expr (se, expr);
/* Deals with variable in common block. Get the field declaration. */
if (TREE_CODE (se->expr) == COMPONENT_REF)
se->expr = TREE_OPERAND (se->expr, 1);
/* Deals with dummy argument. Get the parameter declaration. */
else if (TREE_CODE (se->expr) == INDIRECT_REF)
se->expr = TREE_OPERAND (se->expr, 0);
}
/* Translate a label assignment statement. */
tree
gfc_trans_label_assign (gfc_code * code)
{
tree label_tree;
gfc_se se;
tree len;
tree addr;
tree len_tree;
int label_len;
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr1);
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
label_tree = gfc_get_label_decl (code->label1);
if (code->label1->defined == ST_LABEL_TARGET
|| code->label1->defined == ST_LABEL_DO_TARGET)
{
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = build_int_cst (gfc_charlen_type_node, -1);
}
else
{
gfc_expr *format = code->label1->format;
label_len = format->value.character.length;
len_tree = build_int_cst (gfc_charlen_type_node, label_len);
label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
format->value.character.string);
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
}
gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree));
gfc_add_modify (&se.pre, addr, label_tree);
return gfc_finish_block (&se.pre);
}
/* Translate a GOTO statement. */
tree
gfc_trans_goto (gfc_code * code)
{
locus loc = code->loc;
tree assigned_goto;
tree target;
tree tmp;
gfc_se se;
if (code->label1 != NULL)
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
/* ASSIGNED GOTO. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_label_variable (&se, code->expr1);
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1));
gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
"Assigned label is not a target label");
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
/* We're going to ignore a label list. It does not really change the
statement's semantics (because it is just a further restriction on
what's legal code); before, we were comparing label addresses here, but
that's a very fragile business and may break with optimization. So
just ignore it. */
target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
assigned_goto);
gfc_add_expr_to_block (&se.pre, target);
return gfc_finish_block (&se.pre);
}
/* Translate an ENTRY statement. Just adds a label for this entry point. */
tree
gfc_trans_entry (gfc_code * code)
{
return build1_v (LABEL_EXPR, code->ext.entry->label);
}
/* Replace a gfc_ss structure by another both in the gfc_se struct
and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
to replace a variable ss by the corresponding temporary. */
static void
replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
{
gfc_ss **sess, **loopss;
/* The old_ss is a ss for a single variable. */
gcc_assert (old_ss->info->type == GFC_SS_SECTION);
for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
if (*sess == old_ss)
break;
gcc_assert (*sess != gfc_ss_terminator);
*sess = new_ss;
new_ss->next = old_ss->next;
/* Make sure that trailing references are not lost. */
if (old_ss->info
&& old_ss->info->data.array.ref
&& old_ss->info->data.array.ref->next
&& !(new_ss->info->data.array.ref
&& new_ss->info->data.array.ref->next))
new_ss->info->data.array.ref = old_ss->info->data.array.ref;
for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
loopss = &((*loopss)->loop_chain))
if (*loopss == old_ss)
break;
gcc_assert (*loopss != gfc_ss_terminator);
*loopss = new_ss;
new_ss->loop_chain = old_ss->loop_chain;
new_ss->loop = old_ss->loop;
gfc_free_ss (old_ss);
}
/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
elemental subroutines. Make temporaries for output arguments if any such
dependencies are found. Output arguments are chosen because internal_unpack
can be used, as is, to copy the result back to the variable. */
static void
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
gfc_symbol * sym, gfc_actual_arglist * arg,
gfc_dep_check check_variable)
{
gfc_actual_arglist *arg0;
gfc_expr *e;
gfc_formal_arglist *formal;
gfc_se parmse;
gfc_ss *ss;
gfc_symbol *fsym;
tree data;
tree size;
tree tmp;
if (loopse->ss == NULL)
return;
ss = loopse->ss;
arg0 = arg;
formal = gfc_sym_get_dummy_args (sym);
/* Loop over all the arguments testing for dependencies. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
if (e == NULL)
continue;
/* Obtain the info structure for the current argument. */
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
if (ss->info->expr == e)
break;
/* If there is a dependency, create a temporary and use it
instead of the variable. */
fsym = formal ? formal->sym : NULL;
if (e->expr_type == EXPR_VARIABLE
&& e->rank && fsym
&& fsym->attr.intent != INTENT_IN
&& gfc_check_fncall_dependency (e, fsym->attr.intent,
sym, arg0, check_variable))
{
tree initial, temptype;
stmtblock_t temp_post;
gfc_ss *tmp_ss;
tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
GFC_SS_SECTION);
gfc_mark_ss_chain_used (tmp_ss, 1);
tmp_ss->info->expr = ss->info->expr;
replace_ss (loopse, ss, tmp_ss);
/* Obtain the argument descriptor for unpacking. */
gfc_init_se (&parmse, NULL);
parmse.want_pointer = 1;
gfc_conv_expr_descriptor (&parmse, e);
gfc_add_block_to_block (&se->pre, &parmse.pre);
/* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
initialize the array temporary with a copy of the values. */
if (fsym->attr.intent == INTENT_INOUT
|| (fsym->ts.type ==BT_DERIVED
&& fsym->attr.intent == INTENT_OUT))
initial = parmse.expr;
/* For class expressions, we always initialize with the copy of
the values. */
else if (e->ts.type == BT_CLASS)
initial = parmse.expr;
else
initial = NULL_TREE;
if (e->ts.type != BT_CLASS)
{
/* Find the type of the temporary to create; we don't use the type
of e itself as this breaks for subcomponent-references in e
(where the type of e is that of the final reference, but
parmse.expr's type corresponds to the full derived-type). */
/* TODO: Fix this somehow so we don't need a temporary of the whole
array but instead only the components referenced. */
temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
temptype = TREE_TYPE (temptype);
temptype = gfc_get_element_type (temptype);
}
else
/* For class arrays signal that the size of the dynamic type has to
be obtained from the vtable, using the 'initial' expression. */
temptype = NULL_TREE;
/* Generate the temporary. Cleaning up the temporary should be the
very last thing done, so we add the code to a new block and add it
to se->post as last instructions. */
size = gfc_create_var (gfc_array_index_type, NULL);
data = gfc_create_var (pvoid_type_node, NULL);
gfc_init_block (&temp_post);
tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
temptype, initial, false, true,
false, &arg->expr->where);
gfc_add_modify (&se->pre, size, tmp);
tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
gfc_add_modify (&se->pre, data, tmp);
/* Update other ss' delta. */
gfc_set_delta (loopse->loop);
/* Copy the result back using unpack..... */
if (e->ts.type != BT_CLASS)
tmp = build_call_expr_loc (input_location,
gfor_fndecl_in_unpack, 2, parmse.expr, data);
else
{
/* ... except for class results where the copy is
unconditional. */
tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
tmp = gfc_conv_descriptor_data_get (tmp);
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMCPY),
3, tmp, data,
fold_convert (size_type_node, size));
}
gfc_add_expr_to_block (&se->post, tmp);
/* parmse.pre is already added above. */
gfc_add_block_to_block (&se->post, &parmse.post);
gfc_add_block_to_block (&se->post, &temp_post);
}
}
}
/* Get the interface symbol for the procedure corresponding to the given call.
We can't get the procedure symbol directly as we have to handle the case
of (deferred) type-bound procedures. */
static gfc_symbol *
get_proc_ifc_for_call (gfc_code *c)
{
gfc_symbol *sym;
gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
sym = gfc_get_proc_ifc_for_expr (c->expr1);
/* Fall back/last resort try. */
if (sym == NULL)
sym = c->resolved_sym;
return sym;
}
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
gfc_trans_call (gfc_code * code, bool dependency_check,
tree mask, tree count1, bool invert)
{
gfc_se se;
gfc_ss * ss;
int has_alternate_specifier;
gfc_dep_check check_variable;
tree index = NULL_TREE;
tree maskexpr = NULL_TREE;
tree tmp;
bool is_intrinsic_mvbits;
/* A CALL starts a new block because the actual arguments may have to
be evaluated first. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gcc_assert (code->resolved_sym);
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
get_proc_ifc_for_call (code),
GFC_SS_REFERENCE);
/* MVBITS is inlined but needs the dependency checking found here. */
is_intrinsic_mvbits = code->resolved_isym
&& code->resolved_isym->id == GFC_ISYM_MVBITS;
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)
{
if (is_intrinsic_mvbits)
{
has_alternate_specifier = 0;
gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL);
}
else
{
/* Translate the call. */
has_alternate_specifier =
gfc_conv_procedure_call (&se, code->resolved_sym,
code->ext.actual, code->expr1, NULL);
/* A subroutine without side-effect, by definition, does nothing! */
TREE_SIDE_EFFECTS (se.expr) = 1;
}
/* Chain the pieces together and return the block. */
if (has_alternate_specifier)
{
gfc_code *select_code;
gfc_symbol *sym;
select_code = code->next;
gcc_assert(select_code->op == EXEC_SELECT);
sym = select_code->expr1->symtree->n.sym;
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
if (sym->backend_decl == NULL)
sym->backend_decl = gfc_get_symbol_decl (sym);
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
}
else
gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
}
else
{
/* An elemental subroutine call with array valued arguments has
to be scalarized. */
gfc_loopinfo loop;
stmtblock_t body;
stmtblock_t block;
gfc_se loopse;
gfc_se depse;
/* gfc_walk_elemental_function_args renders the ss chain in the
reverse order to the actual argument order. */
ss = gfc_reverse_ss (ss);
/* Initialize the loop. */
gfc_init_se (&loopse, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
/* TODO: gfc_conv_loop_setup generates a temporary for vector
subscripts. This could be prevented in the elemental case
as temporaries are handled separatedly
(below in gfc_conv_elemental_dependencies). */
if (code->expr1)
gfc_conv_loop_setup (&loop, &code->expr1->where);
else
gfc_conv_loop_setup (&loop, &code->loc);
gfc_mark_ss_chain_used (ss, 1);
/* Convert the arguments, checking for dependencies. */
gfc_copy_loopinfo_to_se (&loopse, &loop);
loopse.ss = ss;
/* For operator assignment, do dependency checking. */
if (dependency_check)
check_variable = ELEM_CHECK_VARIABLE;
else
check_variable = ELEM_DONT_CHECK_VARIABLE;
gfc_init_se (&depse, NULL);
gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
code->ext.actual, check_variable);
gfc_add_block_to_block (&loop.pre, &depse.pre);
gfc_add_block_to_block (&loop.post, &depse.post);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
gfc_init_block (&block);
if (mask && count1)
{
/* Form the mask expression according to the mask. */
index = count1;
maskexpr = gfc_build_array_ref (mask, index, NULL);
if (invert)
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (maskexpr), maskexpr);
}
if (is_intrinsic_mvbits)
{
has_alternate_specifier = 0;
gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop);
}
else
{
/* Add the subroutine call to the block. */
gfc_conv_procedure_call (&loopse, code->resolved_sym,
code->ext.actual, code->expr1,
NULL);
}
if (mask && count1)
{
tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&loopse.pre, tmp);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify (&loopse.pre, count1, tmp);
}
else
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
gfc_add_block_to_block (&block, &loopse.pre);
gfc_add_block_to_block (&block, &loopse.post);
/* Finish up the loop block and the loop. */
gfc_add_expr_to_block (&body, gfc_finish_block (&block));
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
return gfc_finish_block (&se.pre);
}
/* Translate the RETURN statement. */
tree
gfc_trans_return (gfc_code * code)
{
if (code->expr1)
{
gfc_se se;
tree tmp;
tree result;
/* If code->expr is not NULL, this return statement must appear
in a subroutine and current_fake_result_decl has already
been generated. */
result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning (0,
"An alternate return at %L without a * dummy argument",
&code->expr1->where);
return gfc_generate_return ();
}
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_expr (&se, code->expr1);
/* Note that the actually returned expression is a simple value and
does not depend on any pointers or such; thus we can clean-up with
se.post before returning. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
result, fold_convert (TREE_TYPE (result),
se.expr));
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
tmp = gfc_generate_return ();
gfc_add_expr_to_block (&se.pre, tmp);
return gfc_finish_block (&se.pre);
}
return gfc_generate_return ();
}
/* Translate the PAUSE statement. We have to translate this statement
to a runtime library call. */
tree
gfc_trans_pause (gfc_code * code)
{
tree gfc_int8_type_node = gfc_get_int_type (8);
gfc_se se;
tree tmp;
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr1 == NULL)
{
tmp = build_int_cst (size_type_node, 0);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_string, 2,
build_int_cst (pchar_type_node, 0), tmp);
}
else if (code->expr1->ts.type == BT_INTEGER)
{
gfc_conv_expr (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_numeric, 1,
fold_convert (gfc_int8_type_node, se.expr));
}
else
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_pause_string, 2,
se.expr, fold_convert (size_type_node,
se.string_length));
}
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
/* Translate the STOP statement. We have to translate this statement
to a runtime library call. */
tree
gfc_trans_stop (gfc_code *code, bool error_stop)
{
gfc_se se;
tree tmp;
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr1 == NULL)
{
tmp = build_int_cst (size_type_node, 0);
tmp = build_call_expr_loc (input_location,
error_stop
? (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_error_stop_str
: gfor_fndecl_error_stop_string)
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_str
: gfor_fndecl_stop_string),
3, build_int_cst (pchar_type_node, 0), tmp,
boolean_false_node);
}
else if (code->expr1->ts.type == BT_INTEGER)
{
gfc_conv_expr (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
error_stop
? (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_error_stop
: gfor_fndecl_error_stop_numeric)
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_numeric
: gfor_fndecl_stop_numeric), 2,
fold_convert (integer_type_node, se.expr),
boolean_false_node);
}
else
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
error_stop
? (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_error_stop_str
: gfor_fndecl_error_stop_string)
: (flag_coarray == GFC_FCOARRAY_LIB
? gfor_fndecl_caf_stop_str
: gfor_fndecl_stop_string),
3, se.expr, fold_convert (size_type_node,
se.string_length),
boolean_false_node);
}
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
/* Translate the FAIL IMAGE statement. */
tree
gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
return build_call_expr_loc (input_location,
gfor_fndecl_caf_fail_image, 0);
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
/* Translate the FORM TEAM statement. */
tree
gfc_trans_form_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
gfc_se se;
gfc_se argse1, argse2;
tree team_id, team_type, tmp;
gfc_init_se (&se, NULL);
gfc_init_se (&argse1, NULL);
gfc_init_se (&argse2, NULL);
gfc_start_block (&se.pre);
gfc_conv_expr_val (&argse1, code->expr1);
gfc_conv_expr_val (&argse2, code->expr2);
team_id = fold_convert (integer_type_node, argse1.expr);
team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr);
gfc_add_block_to_block (&se.pre, &argse1.pre);
gfc_add_block_to_block (&se.pre, &argse2.pre);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_form_team, 3,
team_id, team_type,
build_int_cst (integer_type_node, 0));
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_block_to_block (&se.pre, &argse1.post);
gfc_add_block_to_block (&se.pre, &argse2.post);
return gfc_finish_block (&se.pre);
}
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
/* Translate the CHANGE TEAM statement. */
tree
gfc_trans_change_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
gfc_se argse;
tree team_type, tmp;
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_change_team, 2, team_type,
build_int_cst (integer_type_node, 0));
gfc_add_expr_to_block (&argse.pre, tmp);
gfc_add_block_to_block (&argse.pre, &argse.post);
return gfc_finish_block (&argse.pre);
}
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
/* Translate the END TEAM statement. */
tree
gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
return build_call_expr_loc (input_location,
gfor_fndecl_caf_end_team, 1,
build_int_cst (pchar_type_node, 0));
}
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
/* Translate the SYNC TEAM statement. */
tree
gfc_trans_sync_team (gfc_code *code)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
{
gfc_se argse;
tree team_type, tmp;
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_caf_sync_team, 2,
team_type,
build_int_cst (integer_type_node, 0));
gfc_add_expr_to_block (&argse.pre, tmp);
gfc_add_block_to_block (&argse.pre, &argse.post);
return gfc_finish_block (&argse.pre);
}
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
{
gfc_se se, argse;
tree stat = NULL_TREE, stat2 = NULL_TREE;
tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE;
/* Short cut: For single images without STAT= or LOCK_ACQUIRED
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB)
return NULL_TREE;
if (code->expr2)
{
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr2);
stat = argse.expr;
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
stat = null_pointer_node;
if (code->expr4)
{
gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr4);
lock_acquired = argse.expr;
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
lock_acquired = null_pointer_node;
gfc_start_block (&se.pre);
if (flag_coarray == GFC_FCOARRAY_LIB)
{
tree tmp, token, image_index, errmsg, errmsg_len;
tree index = build_zero_cst (gfc_array_index_type);
tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
|| code->expr1->symtree->n.sym->ts.u.derived->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
|| code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
!= ISOFORTRAN_LOCK_TYPE)
{
gfc_error ("Sorry, the lock component of derived type at %L is not "
"yet supported", &code->expr1->where);
return NULL_TREE;
}
gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
code->expr1);
if (gfc_is_coindexed (code->expr1))
image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
else
image_index = integer_zero_node;
/* For arrays, obtain the array index. */
if (gfc_expr_attr (code->expr1).dimension)
{
tree desc, tmp, extent, lbound, ubound;
gfc_array_ref *ar, ar2;
int i;
/* TODO: Extend this, once DT components are supported. */
ar = &code->expr1->ref->u.ar;
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, code->expr1);
gfc_add_block_to_block (&se.pre, &argse.pre);
desc = argse.expr;
*ar = ar2;
extent = build_one_cst (gfc_array_index_type);
for (i = 0; i < ar->dimen; i++)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
gfc_add_block_to_block (&argse.pre, &argse.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (lbound), argse.expr, lbound);
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
index = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (tmp), index, tmp);
if (i < ar->dimen - 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);
}
}
}
/* errmsg. */
if (code->expr3)
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
errmsg_len = fold_convert (size_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
errmsg_len = build_zero_cst (size_type_node);
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
{
stat2 = stat;
stat = gfc_create_var (integer_type_node, "stat");
}
if (lock_acquired != null_pointer_node
&& TREE_TYPE (lock_acquired) != integer_type_node)
{
lock_acquired2 = lock_acquired;
lock_acquired = gfc_create_var (integer_type_node, "acquired");
}
index = fold_convert (size_type_node, index);
if (op == EXEC_LOCK)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
token, index, image_index,
lock_acquired != null_pointer_node
? gfc_build_addr_expr (NULL, lock_acquired)
: lock_acquired,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
else
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
token, index, image_index,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
gfc_add_expr_to_block (&se.pre, tmp);
/* It guarantees memory consistency within the same segment */
tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&se.pre, tmp);
if (stat2 != NULL_TREE)
gfc_add_modify (&se.pre, stat2,
fold_convert (TREE_TYPE (stat2), stat));
if (lock_acquired2 != NULL_TREE)
gfc_add_modify (&se.pre, lock_acquired2,
fold_convert (TREE_TYPE (lock_acquired2),
lock_acquired));
return gfc_finish_block (&se.pre);
}
if (stat != NULL_TREE)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
if (lock_acquired != NULL_TREE)
gfc_add_modify (&se.pre, lock_acquired,
fold_convert (TREE_TYPE (lock_acquired),
boolean_true_node));
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
{
gfc_se se, argse;
tree stat = NULL_TREE, stat2 = NULL_TREE;
tree until_count = NULL_TREE;
if (code->expr2)
{
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr2);
stat = argse.expr;
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
stat = null_pointer_node;
if (code->expr4)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr4);
until_count = fold_convert (integer_type_node, argse.expr);
}
else
until_count = integer_one_node;
if (flag_coarray != GFC_FCOARRAY_LIB)
{
gfc_start_block (&se.pre);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
if (op == EXEC_EVENT_POST)
gfc_add_modify (&se.pre, argse.expr,
fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (argse.expr), argse.expr,
build_int_cst (TREE_TYPE (argse.expr), 1)));
else
gfc_add_modify (&se.pre, argse.expr,
fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (argse.expr), argse.expr,
fold_convert (TREE_TYPE (argse.expr),
until_count)));
if (stat != NULL_TREE)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
return gfc_finish_block (&se.pre);
}
gfc_start_block (&se.pre);
tree tmp, token, image_index, errmsg, errmsg_len;
tree index = build_zero_cst (gfc_array_index_type);
tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
|| code->expr1->symtree->n.sym->ts.u.derived->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
|| code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE)
{
gfc_error ("Sorry, the event component of derived type at %L is not "
"yet supported", &code->expr1->where);
return NULL_TREE;
}
gfc_init_se (&argse, NULL);
gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE,
code->expr1);
gfc_add_block_to_block (&se.pre, &argse.pre);
if (gfc_is_coindexed (code->expr1))
image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
else
image_index = integer_zero_node;
/* For arrays, obtain the array index. */
if (gfc_expr_attr (code->expr1).dimension)
{
tree desc, tmp, extent, lbound, ubound;
gfc_array_ref *ar, ar2;
int i;
/* TODO: Extend this, once DT components are supported. */
ar = &code->expr1->ref->u.ar;
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, code->expr1);
gfc_add_block_to_block (&se.pre, &argse.pre);
desc = argse.expr;
*ar = ar2;
extent = build_one_cst (gfc_array_index_type);
for (i = 0; i < ar->dimen; i++)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
gfc_add_block_to_block (&argse.pre, &argse.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (lbound), argse.expr, lbound);
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
index = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (tmp), index, tmp);
if (i < ar->dimen - 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);
}
}
}
/* errmsg. */
if (code->expr3)
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
errmsg_len = fold_convert (size_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
errmsg_len = build_zero_cst (size_type_node);
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
{
stat2 = stat;
stat = gfc_create_var (integer_type_node, "stat");
}
index = fold_convert (size_type_node, index);
if (op == EXEC_EVENT_POST)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
token, index, image_index,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
else
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
token, index, until_count,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
gfc_add_expr_to_block (&se.pre, tmp);
/* It guarantees memory consistency within the same segment */
tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&se.pre, tmp);
if (stat2 != NULL_TREE)
gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gfc_se se, argse;
tree tmp;
tree images = NULL_TREE, stat = NULL_TREE,
errmsg = NULL_TREE, errmsglen = NULL_TREE;
/* Short cut: For single images without bound checking or without STAT=,
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& flag_coarray != GFC_FCOARRAY_LIB)
return NULL_TREE;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr1 && code->expr1->rank == 0)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
images = argse.expr;
}
if (code->expr2)
{
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE
|| code->expr2->expr_type == EXPR_FUNCTION);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr2);
stat = argse.expr;
}
else
stat = null_pointer_node;
if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB)
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE
|| code->expr3->expr_type == EXPR_FUNCTION);
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
errmsglen = fold_convert (size_type_node, argse.string_length);
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
{
errmsg = null_pointer_node;
errmsglen = build_int_cst (size_type_node, 0);
}
/* Check SYNC IMAGES(imageset) for valid image index.
FIXME: Add a check for image-set arrays. */
if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& code->expr1->rank == 0)
{
tree images2 = fold_convert (integer_type_node, images);
tree cond;
if (flag_coarray != GFC_FCOARRAY_LIB)
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
images, build_int_cst (TREE_TYPE (images), 1));
else
{
tree cond2;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2, integer_zero_node,
build_int_cst (integer_type_node, -1));
cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
images2, tmp);
cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
images,
build_int_cst (TREE_TYPE (images), 1));
cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, cond, cond2);
}
gfc_trans_runtime_check (true, false, cond, &se.pre,
&code->expr1->where, "Invalid image number "
"%d in SYNC IMAGES", images2);
}
/* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
image control statements SYNC IMAGES and SYNC ALL. */
if (flag_coarray == GFC_FCOARRAY_LIB)
{
tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&se.pre, tmp);
}
if (flag_coarray != GFC_FCOARRAY_LIB)
{
/* Set STAT to zero. */
if (code->expr2)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
}
else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY)
{
/* SYNC ALL => stat == null_pointer_node
SYNC ALL(stat=s) => stat has an integer type
If "stat" has the wrong integer type, use a temp variable of
the right type and later cast the result back into "stat". */
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
{
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
if(type == EXEC_SYNC_MEMORY)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory,
3, stat, errmsg, errmsglen);
else
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
3, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
{
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
3, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_modify (&se.pre, stat,
fold_convert (TREE_TYPE (stat), tmp_stat));
}
}
else
{
tree len;
gcc_assert (type == EXEC_SYNC_IMAGES);
if (!code->expr1)
{
len = build_int_cst (integer_type_node, -1);
images = null_pointer_node;
}
else if (code->expr1->rank == 0)
{
len = build_int_cst (integer_type_node, 1);
images = gfc_build_addr_expr (NULL_TREE, images);
}
else
{
/* FIXME. */
if (code->expr1->ts.kind != gfc_c_int_kind)
gfc_fatal_error ("Sorry, only support for integer kind %d "
"implemented for image-set at %L",
gfc_c_int_kind, &code->expr1->where);
gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
images = se.expr;
tmp = gfc_typenode_for_spec (&code->expr1->ts);
if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
tmp = gfc_get_element_type (tmp);
len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
TREE_TYPE (len), len,
fold_convert (TREE_TYPE (len),
TYPE_SIZE_UNIT (tmp)));
len = fold_convert (integer_type_node, len);
}
/* SYNC IMAGES(imgs) => stat == null_pointer_node
SYNC IMAGES(imgs,stat=s) => stat has an integer type
If "stat" has the wrong integer type, use a temp variable of
the right type and later cast the result back into "stat". */
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
{
if (TREE_TYPE (stat) == integer_type_node)
stat = gfc_build_addr_expr (NULL, stat);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, stat, errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
}
else
{
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
5, fold_convert (integer_type_node, len),
images, gfc_build_addr_expr (NULL, tmp_stat),
errmsg, errmsglen);
gfc_add_expr_to_block (&se.pre, tmp);
gfc_add_modify (&se.pre, stat,
fold_convert (TREE_TYPE (stat), tmp_stat));
}
}
return gfc_finish_block (&se.pre);
}
/* Generate GENERIC for the IF construct. This function also deals with
the simple IF statement, because the front end translates the IF
statement into an IF construct.
We translate:
IF (cond) THEN
then_clause
ELSEIF (cond2)
elseif_clause
ELSE
else_clause
ENDIF
into:
pre_cond_s;
if (cond_s)
{
then_clause;
}
else
{
pre_cond_s
if (cond_s)
{
elseif_clause
}
else
{
else_clause;
}
}
where COND_S is the simplified version of the predicate. PRE_COND_S
are the pre side-effects produced by the translation of the
conditional.
We need to build the chain recursively otherwise we run into
problems with folding incomplete statements. */
static tree
gfc_trans_if_1 (gfc_code * code)
{
gfc_se if_se;
tree stmt, elsestmt;
locus saved_loc;
location_t loc;
/* Check for an unconditional ELSE clause. */
if (!code->expr1)
return gfc_trans_code (code->next);
/* Initialize a statement builder for each block. Puts in NULL_TREEs. */
gfc_init_se (&if_se, NULL);
gfc_start_block (&if_se.pre);
/* Calculate the IF condition expression. */
if (code->expr1->where.lb)
{
gfc_save_backend_locus (&saved_loc);
gfc_set_backend_locus (&code->expr1->where);
}
gfc_conv_expr_val (&if_se, code->expr1);
if (code->expr1->where.lb)
gfc_restore_backend_locus (&saved_loc);
/* Translate the THEN clause. */
stmt = gfc_trans_code (code->next);
/* Translate the ELSE clause. */
if (code->block)
elsestmt = gfc_trans_if_1 (code->block);
else
elsestmt = build_empty_stmt (input_location);
/* Build the condition expression and add it to the condition block. */
loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where)
: input_location;
stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
elsestmt);
gfc_add_expr_to_block (&if_se.pre, stmt);
/* Finish off this statement. */
return gfc_finish_block (&if_se.pre);
}
tree
gfc_trans_if (gfc_code * code)
{
stmtblock_t body;
tree exit_label;
/* Create exit label so it is available for trans'ing the body code. */
exit_label = gfc_build_label_decl (NULL_TREE);
code->exit_label = exit_label;
/* Translate the actual code in code->block. */
gfc_init_block (&body);
gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
/* Add exit label. */
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
return gfc_finish_block (&body);
}
/* Translate an arithmetic IF expression.
IF (cond) label1, label2, label3 translates to
if (cond <= 0)
{
if (cond < 0)
goto label1;
else // cond == 0
goto label2;
}
else // cond > 0
goto label3;
An optimized version can be generated in case of equal labels.
E.g., if label1 is equal to label2, we can translate it to
if (cond <= 0)
goto label1;
else
goto label3;
*/
tree
gfc_trans_arithmetic_if (gfc_code * code)
{
gfc_se se;
tree tmp;
tree branch1;
tree branch2;
tree zero;
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
/* Pre-evaluate COND. */
gfc_conv_expr_val (&se, code->expr1);
se.expr = gfc_evaluate_now (se.expr, &se.pre);
/* Build something to compare with. */
zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
if (code->label1->value != code->label2->value)
{
/* If (cond < 0) take branch1 else take branch2.
First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
if (code->label1->value != code->label3->value)
tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
se.expr, zero);
else
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
se.expr, zero);
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
tmp, branch1, branch2);
}
else
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
if (code->label1->value != code->label3->value
&& code->label2->value != code->label3->value)
{
/* if (cond <= 0) take branch1 else take branch2. */
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
se.expr, zero);
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
tmp, branch1, branch2);
}
/* Append the COND_EXPR to the evaluation of COND, and return. */
gfc_add_expr_to_block (&se.pre, branch1);
return gfc_finish_block (&se.pre);
}
/* Translate a CRITICAL block. */
tree
gfc_trans_critical (gfc_code *code)
{
stmtblock_t block;
tree tmp, token = NULL_TREE;
gfc_start_block (&block);
if (flag_coarray == GFC_FCOARRAY_LIB)
{
tree zero_size = build_zero_cst (size_type_node);
token = gfc_get_symbol_decl (code->resolved_sym);
token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
token, zero_size, integer_one_node,
null_pointer_node, null_pointer_node,
null_pointer_node, zero_size);
gfc_add_expr_to_block (&block, tmp);
/* It guarantees memory consistency within the same segment */
tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""),
NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE),
NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&block, tmp);
}
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&block, tmp);
if (flag_coarray == GFC_FCOARRAY_LIB)
{
tree zero_size = build_zero_cst (size_type_node);
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
token, zero_size, integer_one_node,
null_pointer_node, null_pointer_node,
zero_size);
gfc_add_expr_to_block (&block, tmp);
/* It guarantees memory consistency within the same segment */
tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
gfc_build_string_const (1, ""),
NULL_TREE, NULL_TREE,
tree_cons (NULL_TREE, tmp, NULL_TREE),
NULL_TREE);
ASM_VOLATILE_P (tmp) = 1;
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
}
/* Return true, when the class has a _len component. */
static bool
class_has_len_component (gfc_symbol *sym)
{
gfc_component *comp = sym->ts.u.derived->components;
while (comp)
{
if (strcmp (comp->name, "_len") == 0)
return true;
comp = comp->next;
}
return false;
}
static void
copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
{
int n;
tree dim;
tree tmp;
tree tmp2;
tree size;
tree offset;
offset = gfc_index_zero_node;
/* Use memcpy to copy the descriptor. The size is the minimum of
the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
size = fold_build2_loc (input_location, MIN_EXPR,
TREE_TYPE (tmp), tmp, tmp2);
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3,
gfc_build_addr_expr (NULL_TREE, dst),
gfc_build_addr_expr (NULL_TREE, src),
fold_convert (size_type_node, size));
gfc_add_expr_to_block (block, tmp);
/* Set the offset correctly. */
for (n = 0; n < rank; n++)
{
dim = gfc_rank_cst[n];
tmp = gfc_conv_descriptor_lbound_get (src, dim);
tmp2 = gfc_conv_descriptor_stride_get (src, dim);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
tmp, tmp2);
offset = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (offset), offset, tmp);
offset = gfc_evaluate_now (offset, block);
}
gfc_conv_descriptor_offset_set (block, dst, offset);
}
/* Do proper initialization for ASSOCIATE names. */
static void
trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_expr *e;
tree tmp;
bool class_target;
bool unlimited;
tree desc;
tree offset;
tree dim;
int n;
tree charlen;
bool need_len_assign;
bool whole_array = true;
gfc_ref *ref;
gfc_symbol *sym2;
gcc_assert (sym->assoc);
e = sym->assoc->target;
class_target = (e->expr_type == EXPR_VARIABLE)
&& (gfc_is_class_scalar_expr (e)
|| gfc_is_class_array_ref (e, NULL));
unlimited = UNLIMITED_POLY (e);
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
&& ref->u.ar.type == AR_FULL
&& ref->next)
{
whole_array = false;
break;
}
/* Assignments to the string length need to be generated, when
( sym is a char array or
sym has a _len component)
and the associated expression is unlimited polymorphic, which is
not (yet) correctly in 'unlimited', because for an already associated
BT_DERIVED the u-poly flag is not set, i.e.,
__tmp_CHARACTER_0_1 => w => arg
^ generated temp ^ from code, the w does not have the u-poly
flag set, where UNLIMITED_POLY(e) expects it. */
need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
&& e->ts.u.derived->attr.unlimited_polymorphic))
&& (sym->ts.type == BT_CHARACTER
|| ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
&& class_has_len_component (sym)))
&& !sym->attr.select_rank_temporary);
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. Select rank temporaries need somewhat different treatment
to other associate names and case temporaries. This because the selector
is assumed rank and so the offset in particular has to be changed. Also,
the case temporaries carry both allocatable and target attributes if
present in the selector. This means that an allocatation or change of
association can occur and so has to be dealt with. */
if (sym->attr.select_rank_temporary)
{
gfc_se se;
tree class_decl = NULL_TREE;
int rank = 0;
bool class_ptr;
sym2 = e->symtree->n.sym;
gfc_init_se (&se, NULL);
if (e->ts.type == BT_CLASS)
{
/* Go straight to the class data. */
if (sym2->attr.dummy && !sym2->attr.optional)
{
class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ?
GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) :
sym2->backend_decl;
if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
class_decl = build_fold_indirect_ref_loc (input_location,
class_decl);
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
se.expr = gfc_class_data_get (class_decl);
}
else
{
class_decl = sym2->backend_decl;
gfc_conv_expr_descriptor (&se, e);
if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
se.expr = build_fold_indirect_ref_loc (input_location,
se.expr);
}
if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
rank = CLASS_DATA (sym)->as->rank;
}
else
{
gfc_conv_expr_descriptor (&se, e);
if (sym->as && sym->as->rank > 0)
rank = sym->as->rank;
}
desc = sym->backend_decl;
/* The SELECT TYPE mechanisms turn class temporaries into pointers, which
point to the selector. */
class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
if (class_ptr)
{
tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
tmp = gfc_build_addr_expr (NULL, tmp);
gfc_add_modify (&se.pre, desc, tmp);
tmp = gfc_class_vptr_get (class_decl);
gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
if (UNLIMITED_POLY (sym))
gfc_add_modify (&se.pre, gfc_class_len_get (desc),
gfc_class_len_get (class_decl));
desc = gfc_class_data_get (desc);
}
/* SELECT RANK temporaries can carry the allocatable and pointer
attributes so the selector descriptor must be copied in and
copied out. */
if (rank > 0)
copy_descriptor (&se.pre, desc, se.expr, rank);
else
{
tmp = gfc_conv_descriptor_data_get (se.expr);
gfc_add_modify (&se.pre, desc,
fold_convert (TREE_TYPE (desc), tmp));
}
/* Deal with associate_name => selector. Class associate names are
treated in the same way as in SELECT TYPE. */
sym2 = sym->assoc->target->symtree->n.sym;
if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
{
sym2 = sym2->assoc->target->symtree->n.sym;
se.expr = sym2->backend_decl;
if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
se.expr = build_fold_indirect_ref_loc (input_location,
se.expr);
}
/* There could have been reallocation. Copy descriptor back to the
selector and update the offset. */
if (sym->attr.allocatable || sym->attr.pointer
|| (sym->ts.type == BT_CLASS
&& (CLASS_DATA (sym)->attr.allocatable
|| CLASS_DATA (sym)->attr.pointer)))
{
if (rank > 0)
copy_descriptor (&se.post, se.expr, desc, rank);
else
gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
/* The dynamic type could have changed too. */
if (sym->ts.type == BT_CLASS)
{
tmp = sym->backend_decl;
if (class_ptr)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
gfc_class_vptr_get (tmp));
if (UNLIMITED_POLY (sym))
gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
gfc_class_len_get (tmp));
}
}
tmp = gfc_finish_block (&se.post);
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
/* Now all the other kinds of associate variable. */
else if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
tree desc;
bool cst_array_ctor;
desc = sym->backend_decl;
cst_array_ctor = e->expr_type == EXPR_ARRAY
&& gfc_constant_array_constructor_p (e->value.constructor)
&& e->ts.type != BT_CHARACTER;
/* If association is to an expression, evaluate it and create temporary.
Otherwise, get descriptor of target for pointer assignment. */
gfc_init_se (&se, NULL);
if (sym->assoc->variable || cst_array_ctor)
{
se.direct_byref = 1;
se.use_offset = 1;
se.expr = desc;
GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
}
gfc_conv_expr_descriptor (&se, e);
if (sym->ts.type == BT_CHARACTER
&& !se.direct_byref && sym->ts.deferred
&& !sym->attr.select_type_temporary
&& VAR_P (sym->ts.u.cl->backend_decl)
&& se.string_length != sym->ts.u.cl->backend_decl)
{
gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
se.string_length));
}
/* If we didn't already do the pointer assignment, set associate-name
descriptor to the one generated for the temporary. */
if ((!sym->assoc->variable && !cst_array_ctor)
|| !whole_array)
{
int dim;
if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
for (dim = 0; dim < e->rank; ++dim)
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
dim, gfc_index_one_node);
}
/* If this is a subreference array pointer associate name use the
associate variable element size for the value of 'span'. */
if (sym->attr.subref_array_pointer && !se.direct_byref)
{
gcc_assert (e->expr_type == EXPR_VARIABLE);
tmp = gfc_get_array_span (se.expr, e);
gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
}
if (e->expr_type == EXPR_FUNCTION
&& sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.pdt_type)
{
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
sym->as->rank);
gfc_add_expr_to_block (&se.post, tmp);
}
/* Done, register stuff as init / cleanup code. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
/* Temporaries, arising from TYPE IS, just need the descriptor of class
arrays to be assigned directly. */
else if (class_target && sym->attr.dimension
&& (sym->ts.type == BT_DERIVED || unlimited))
{
gfc_se se;
gfc_init_se (&se, NULL);
se.descriptor_only = 1;
/* In a select type the (temporary) associate variable shall point to
a standard fortran array (lower bound == 1), but conv_expr ()
just maps to the input array in the class object, whose lbound may
be arbitrary. conv_expr_descriptor solves this by inserting a
temporary array descriptor. */
gfc_conv_expr_descriptor (&se, e);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
|| GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
{
if (INDIRECT_REF_P (se.expr))
tmp = TREE_OPERAND (se.expr, 0);
else
tmp = se.expr;
gfc_add_modify (&se.pre, sym->backend_decl,
gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)));
}
else
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
if (unlimited)
{
/* Recover the dtype, which has been overwritten by the
assignment from an unlimited polymorphic object. */
tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
gfc_add_modify (&se.pre, tmp,
gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
}
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
/* Do a scalar pointer assignment; this is for scalar variable targets. */
else if (gfc_is_associate_pointer (sym))
{
gfc_se se;
gcc_assert (!sym->attr.dimension);
gfc_init_se (&se, NULL);
/* Class associate-names come this way because they are
unconditionally associate pointers and the symbol is scalar. */
if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
tree target_expr;
/* For a class array we need a descriptor for the selector. */
gfc_conv_expr_descriptor (&se, e);
/* Needed to get/set the _len component below. */
target_expr = se.expr;
/* Obtain a temporary class container for the result. */
gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
/* Set the offset. */
desc = gfc_class_data_get (se.expr);
offset = gfc_index_zero_node;
for (n = 0; n < e->rank; n++)
{
dim = gfc_rank_cst[n];
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
gfc_conv_descriptor_stride_get (desc, dim),
gfc_conv_descriptor_lbound_get (desc, dim));
offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
offset, tmp);
}
if (need_len_assign)
{
if (e->symtree
&& DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
&& GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)
&& TREE_CODE (target_expr) != COMPONENT_REF)
/* Use the original class descriptor stored in the saved
descriptor to get the target_expr. */
target_expr =
GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl);
else
/* Strip the _data component from the target_expr. */
target_expr = TREE_OPERAND (target_expr, 0);
/* Add a reference to the _len comp to the target expr. */
tmp = gfc_class_len_get (target_expr);
/* Get the component-ref for the temp structure's _len comp. */
charlen = gfc_class_len_get (se.expr);
/* Add the assign to the beginning of the block... */
gfc_add_modify (&se.pre, charlen,
fold_convert (TREE_TYPE (charlen), tmp));
/* and the oposite way at the end of the block, to hand changes
on the string length back. */
gfc_add_modify (&se.post, tmp,
fold_convert (TREE_TYPE (tmp), charlen));
/* Length assignment done, prevent adding it again below. */
need_len_assign = false;
}
gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
}
else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
&& CLASS_DATA (e)->attr.dimension)
{
/* This is bound to be a class array element. */
gfc_conv_expr_reference (&se, e);
/* Get the _vptr component of the class object. */
tmp = gfc_get_vptr_from_expr (se.expr);
/* Obtain a temporary class container for the result. */
gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
need_len_assign = false;
}
else
{
/* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
which has the string length included. For CHARACTERS it is still
needed and will be done at the end of this routine. */
gfc_conv_expr (&se, e);
need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
}
if (sym->ts.type == BT_CHARACTER
&& !sym->attr.select_type_temporary
&& VAR_P (sym->ts.u.cl->backend_decl)
&& se.string_length != sym->ts.u.cl->backend_decl)
{
gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
se.string_length));
if (e->expr_type == EXPR_FUNCTION)
{
tmp = gfc_call_free (sym->backend_decl);
gfc_add_expr_to_block (&se.post, tmp);
}
}
if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (TREE_TYPE (se.expr)))
{
/* These are pointer types already. */
tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
}
else
{
tree ctree = gfc_get_class_from_expr (se.expr);
tmp = TREE_TYPE (sym->backend_decl);
/* Coarray scalar component expressions can emerge from
the front end as array elements of the _data field. */
if (sym->ts.type == BT_CLASS
&& e->ts.type == BT_CLASS && e->rank == 0
&& !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree)
{
tree stmp;
tree dtmp;
se.expr = ctree;
dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
ctree = gfc_create_var (dtmp, "class");
stmp = gfc_class_data_get (se.expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp)));
/* Set the fields of the target class variable. */
stmp = gfc_conv_descriptor_data_get (stmp);
dtmp = gfc_class_data_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
stmp = gfc_class_vptr_get (se.expr);
dtmp = gfc_class_vptr_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
if (UNLIMITED_POLY (sym))
{
stmp = gfc_class_len_get (se.expr);
dtmp = gfc_class_len_get (ctree);
stmp = fold_convert (TREE_TYPE (dtmp), stmp);
gfc_add_modify (&se.pre, dtmp, stmp);
}
se.expr = ctree;
}
tmp = gfc_build_addr_expr (tmp, se.expr);
}
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
gfc_finish_block (&se.post));
}
/* Do a simple assignment. This is for scalar expressions, where we
can simply use expression assignment. */
else
{
gfc_expr *lhs;
tree res;
gfc_se se;
gfc_init_se (&se, NULL);
/* resolve.c converts some associate names to allocatable so that
allocation can take place automatically in gfc_trans_assignment.
The frontend prevents them from being either allocated,
deallocated or reallocated. */
if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_descriptor_data_get (tmp);
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
lhs = gfc_lval_expr_from_sym (sym);
res = gfc_trans_assignment (lhs, e, false, true);
gfc_add_expr_to_block (&se.pre, res);
tmp = sym->backend_decl;
if (e->expr_type == EXPR_FUNCTION
&& sym->ts.type == BT_DERIVED
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.pdt_type)
{
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
0);
}
else if (e->expr_type == EXPR_FUNCTION
&& sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->ts.u.derived
&& CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
{
tmp = gfc_class_data_get (tmp);
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
tmp, 0);
}
else if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_descriptor_data_get (tmp);
/* A simple call to free suffices here. */
tmp = gfc_call_free (tmp);
/* Make sure that reallocation on assignment cannot occur. */
sym->attr.allocatable = 0;
}
else
tmp = NULL_TREE;
res = gfc_finish_block (&se.pre);
gfc_add_init_cleanup (block, res, tmp);
gfc_free_expr (lhs);
}
/* Set the stringlength, when needed. */
if (need_len_assign)
{
gfc_se se;
gfc_init_se (&se, NULL);
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
{
/* Deferred strings are dealt with in the preceeding. */
gcc_assert (!e->symtree->n.sym->ts.deferred);
tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
}
else if (e->symtree->n.sym->attr.function
&& e->symtree->n.sym == e->symtree->n.sym->result)
{
tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
tmp = gfc_class_len_get (tmp);
}
else
tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
gfc_get_symbol_decl (sym);
charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
: gfc_class_len_get (sym->backend_decl);
/* Prevent adding a noop len= len. */
if (tmp != charlen)
{
gfc_add_modify (&se.pre, charlen,
fold_convert (TREE_TYPE (charlen), tmp));
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
}
}
/* Translate a BLOCK construct. This is basically what we would do for a
procedure body. */
tree
gfc_trans_block_construct (gfc_code* code)
{
gfc_namespace* ns;
gfc_symbol* sym;
gfc_wrapped_block block;
tree exit_label;
stmtblock_t body;
gfc_association_list *ass;
ns = code->ext.block.ns;
gcc_assert (ns);
sym = ns->proc_name;
gcc_assert (sym);
/* Process local variables. */
gcc_assert (!sym->tlink);
sym->tlink = sym;
gfc_process_block_locals (ns);
/* Generate code including exit-label. */
gfc_init_block (&body);
exit_label = gfc_build_label_decl (NULL_TREE);
code->exit_label = exit_label;
finish_oacc_declare (ns, sym, true);
gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
/* Finish everything. */
gfc_start_wrapped_block (&block, gfc_finish_block (&body));
gfc_trans_deferred_vars (sym, &block);
for (ass = code->ext.block.assoc; ass; ass = ass->next)
trans_associate_var (ass->st->n.sym, &block);
return gfc_finish_wrapped_block (&block);
}
/* Translate the simple DO construct in a C-style manner.
This is where the loop variable has integer type and step +-1.
Following code will generate infinite loop in case where TO is INT_MAX
(for +1 step) or INT_MIN (for -1 step)
We translate a do loop from:
DO dovar = from, to, step
body
END DO
to:
[Evaluate loop bounds and step]
dovar = from;
for (;;)
{
if (dovar > to)
goto end_label;
body;
cycle_label:
dovar += step;
}
end_label:
This helps the optimizers by avoiding the extra pre-header condition and
we save a register as we just compare the updated IV (not a value in
previous step). */
static tree
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
tree from, tree to, tree step, tree exit_cond)
{
stmtblock_t body;
tree type;
tree cond;
tree tmp;
tree saved_dovar = NULL;
tree cycle_label;
tree exit_label;
location_t loc;
type = TREE_TYPE (dovar);
bool is_step_positive = tree_int_cst_sgn (step) > 0;
loc = gfc_get_location (&code->ext.iterator->start->where);
/* Initialize the DO variable: dovar = from. */
gfc_add_modify_loc (loc, pblock, dovar,
fold_convert (TREE_TYPE (dovar), from));
/* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
saved_dovar = gfc_create_var (type, ".saved_dovar");
gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
}
/* Cycle and exit statements are implemented with gotos. */
cycle_label = gfc_build_label_decl (NULL_TREE);
exit_label = gfc_build_label_decl (NULL_TREE);
/* Put the labels where they can be found later. See gfc_trans_do(). */
code->cycle_label = cycle_label;
code->exit_label = exit_label;
/* Loop body. */
gfc_start_block (&body);
/* Exit the loop if there is an I/O result condition or error. */
if (exit_cond)
{
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
exit_cond, tmp,
build_empty_stmt (loc));
gfc_add_expr_to_block (&body, tmp);
}
/* Evaluate the loop condition. */
if (is_step_positive)
cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
fold_convert (type, to));
else
cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
fold_convert (type, to));
cond = gfc_evaluate_now_loc (loc, cond, &body);
if (code->ext.iterator->unroll && cond != error_mark_node)
cond
= build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node, annot_expr_unroll_kind),
build_int_cst (integer_type_node, code->ext.iterator->unroll));
if (code->ext.iterator->ivdep && cond != error_mark_node)
cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node, annot_expr_ivdep_kind),
integer_zero_node);
if (code->ext.iterator->vector && cond != error_mark_node)
cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node, annot_expr_vector_kind),
integer_zero_node);
if (code->ext.iterator->novector && cond != error_mark_node)
cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
build_int_cst (integer_type_node, annot_expr_no_vector_kind),
integer_zero_node);
/* The loop exit. */
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
cond, tmp, build_empty_stmt (loc));
gfc_add_expr_to_block (&body, tmp);
/* Check whether the induction variable is equal to INT_MAX
(respectively to INT_MIN). */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)
: TYPE_MIN_VALUE (type);
tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
dovar, boundary);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop iterates infinitely");
}
/* Main loop body. */
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
gfc_add_expr_to_block (&body, tmp);
/* Label for cycle statements (if needed). */
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&body, tmp);
}
/* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
dovar, saved_dovar);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop variable has been modified");
}
/* Increment the loop variable. */
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
gfc_add_modify_loc (loc, &body, dovar, tmp);
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
/* Finish the loop body. */
tmp = gfc_finish_block (&body);
tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
gfc_add_expr_to_block (pblock, tmp);
/* Add the exit label. */
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (pblock, tmp);
return gfc_finish_block (pblock);
}
/* Translate the DO construct. This obviously is one of the most
important ones to get right with any compiler, but especially
so for Fortran.
We special case some loop forms as described in gfc_trans_simple_do.
For other cases we implement them with a separate loop count,
as described in the standard.
We translate a do loop from:
DO dovar = from, to, step
body
END DO
to:
[evaluate loop bounds and step]
empty = (step > 0 ? to < from : to > from);
countm1 = (to - from) / step;
dovar = from;
if (empty) goto exit_label;
for (;;)
{
body;
cycle_label:
dovar += step
countm1t = countm1;
countm1--;
if (countm1t == 0) goto exit_label;
}
exit_label:
countm1 is an unsigned integer. It is equal to the loop count minus one,
because the loop count itself can overflow. */
tree
gfc_trans_do (gfc_code * code, tree exit_cond)
{
gfc_se se;
tree dovar;
tree saved_dovar = NULL;
tree from;
tree to;
tree step;
tree countm1;
tree type;
tree utype;
tree cond;
tree cycle_label;
tree exit_label;
tree tmp;
stmtblock_t block;
stmtblock_t body;
location_t loc;
gfc_start_block (&block);
loc = gfc_get_location (&code->ext.iterator->start->where);
/* Evaluate all the expressions in the iterator. */
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
gfc_add_block_to_block (&block, &se.pre);
dovar = se.expr;
type = TREE_TYPE (dovar);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->start);
gfc_add_block_to_block (&block, &se.pre);
from = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->end);
gfc_add_block_to_block (&block, &se.pre);
to = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, code->ext.iterator->step);
gfc_add_block_to_block (&block, &se.pre);
step = gfc_evaluate_now (se.expr, &block);
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
build_zero_cst (type));
gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
"DO step value is zero");
}
/* Special case simple loops. */
if (TREE_CODE (type) == INTEGER_TYPE
&& (integer_onep (step)
|| tree_int_cst_equal (step, integer_minus_one_node)))
return gfc_trans_simple_do (code, &block, dovar, from, to, step,
exit_cond);
if (TREE_CODE (type) == INTEGER_TYPE)
utype = unsigned_type_for (type);
else
utype = unsigned_type_for (gfc_array_index_type);
countm1 = gfc_create_var (utype, "countm1");
/* Cycle and exit statements are implemented with gotos. */
cycle_label = gfc_build_label_decl (NULL_TREE);
exit_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (exit_label) = 1;
/* Put these labels where they can be found later. */
code->cycle_label = cycle_label;
code->exit_label = exit_label;
/* Initialize the DO variable: dovar = from. */
gfc_add_modify (&block, dovar, from);
/* Save value for do-tinkering checking. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
saved_dovar = gfc_create_var (type, ".saved_dovar");
gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
}
/* Initialize loop count and jump to exit label if the loop is empty.
This code is executed before we enter the loop body. We generate:
if (step > 0)
{
countm1 = (to - from) / step;
if (to < from)
goto exit_label;
}
else
{
countm1 = (from - to) / -step;
if (to > from)
goto exit_label;
}
*/
if (TREE_CODE (type) == INTEGER_TYPE)
{
tree pos, neg, tou, fromu, stepu, tmp2;
/* The distance from FROM to TO cannot always be represented in a signed
type, thus use unsigned arithmetic, also to avoid any undefined
overflow issues. */
tou = fold_convert (utype, to);
fromu = fold_convert (utype, from);
stepu = fold_convert (utype, step);
/* For a positive step, when to < from, exit, otherwise compute
countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
fold_build2_loc (loc, MINUS_EXPR, utype,
tou, fromu),
stepu);
pos = build2 (COMPOUND_EXPR, void_type_node,
fold_build2 (MODIFY_EXPR, void_type_node,
countm1, tmp2),
build3_loc (loc, COND_EXPR, void_type_node,
gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
build1_loc (loc, GOTO_EXPR, void_type_node,
exit_label), NULL_TREE));
/* For a negative step, when to > from, exit, otherwise compute
countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
fold_build2_loc (loc, MINUS_EXPR, utype,
fromu, tou),
fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
neg = build2 (COMPOUND_EXPR, void_type_node,
fold_build2 (MODIFY_EXPR, void_type_node,
countm1, tmp2),
build3_loc (loc, COND_EXPR, void_type_node,
gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
build1_loc (loc, GOTO_EXPR, void_type_node,
exit_label), NULL_TREE));
tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
build_int_cst (TREE_TYPE (step), 0));
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
gfc_add_expr_to_block (&block, tmp);
}
else
{
tree pos_step;
/* TODO: We could use the same width as the real type.
This would probably cause more problems that it solves
when we implement "long double" types. */
tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
gfc_add_modify (&block, countm1, tmp);
/* We need a special check for empty loops:
empty = (step > 0 ? to < from : to > from); */
pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
build_zero_cst (type));
tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
fold_build2_loc (loc, LT_EXPR,
logical_type_node, to, from),
fold_build2_loc (loc, GT_EXPR,
logical_type_node, to, from));
/* If the loop is empty, go directly to the exit label. */
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
build1_v (GOTO_EXPR, exit_label),
build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
}
/* Loop body. */
gfc_start_block (&body);
/* Main loop body. */
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
gfc_add_expr_to_block (&body, tmp);
/* Label for cycle statements (if needed). */
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
gfc_add_expr_to_block (&body, tmp);
}
/* Check whether someone has modified the loop variable. */
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
{
tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
saved_dovar);
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
"Loop variable has been modified");
}
/* Exit the loop if there is an I/O result condition or error. */
if (exit_cond)
{
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
exit_cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
}
/* Increment the loop variable. */
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
gfc_add_modify_loc (loc, &body, dovar, tmp);
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
/* Initialize countm1t. */
tree countm1t = gfc_create_var (utype, "countm1t");
gfc_add_modify_loc (loc, &body, countm1t, countm1);
/* Decrement the loop count. */
tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
build_int_cst (utype, 1));
gfc_add_modify_loc (loc, &body, countm1, tmp);
/* End with the loop condition. Loop until countm1t == 0. */
cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
build_int_cst (utype, 0));
if (code->ext.iterator->unroll && cond != error_mark_node)
cond
= build3 (ANNOTATE_EXPR, TREE_TYPE (