#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
-#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
#include "gfortran.h"
#include "flags.h"
#include "trans.h"
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
+ tmp = build_int_cst (gfc_int4_type_node, 0);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_pause_numeric, 1, tmp);
+ 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_int4_type_node, se.expr));
}
else
{
if (code->expr1 == NULL)
{
- tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
+ tmp = build_int_cst (gfc_int4_type_node, 0);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_stop_numeric, 1, tmp);
+ error_stop ? gfor_fndecl_error_stop_string
+ : gfor_fndecl_stop_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,
+ error_stop ? gfor_fndecl_error_stop_numeric
+ : gfor_fndecl_stop_numeric, 1,
+ fold_convert (gfc_int4_type_node, se.expr));
}
else
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- error_stop ? gfor_fndecl_error_stop_string
- : gfor_fndecl_stop_string,
- 2, se.expr, se.string_length);
+ error_stop ? gfor_fndecl_error_stop_string
+ : gfor_fndecl_stop_string,
+ 2, se.expr, se.string_length);
}
gfc_add_expr_to_block (&se.pre, tmp);
stmtblock_t body;
tree tmp;
- ns = code->ext.ns;
+ ns = code->ext.block.ns;
gcc_assert (ns);
sym = ns->proc_name;
gcc_assert (sym);
static tree
gfc_trans_character_select (gfc_code *code)
{
- tree init, node, end_label, tmp, type, case_num, label, fndecl;
+ tree init, end_label, tmp, type, case_num, label, fndecl;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_se se;
int n, k;
+ VEC(constructor_elt,gc) *inits = NULL;
/* The jump table types are stored in static variables to avoid
constructing them from scratch every single time. */
}
/* Generate the structure describing the branches */
- init = NULL_TREE;
-
for(d = cp; d; d = d->right)
{
- node = NULL_TREE;
+ VEC(constructor_elt,gc) *node = NULL;
gfc_init_se (&se, NULL);
if (d->low == NULL)
{
- node = tree_cons (ss_string1[k], null_pointer_node, node);
- node = tree_cons (ss_string1_len[k], integer_zero_node, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
}
else
{
gfc_conv_expr_reference (&se, d->low);
- node = tree_cons (ss_string1[k], se.expr, node);
- node = tree_cons (ss_string1_len[k], se.string_length, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
}
if (d->high == NULL)
{
- node = tree_cons (ss_string2[k], null_pointer_node, node);
- node = tree_cons (ss_string2_len[k], integer_zero_node, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
}
else
{
gfc_init_se (&se, NULL);
gfc_conv_expr_reference (&se, d->high);
- node = tree_cons (ss_string2[k], se.expr, node);
- node = tree_cons (ss_string2_len[k], se.string_length, node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
+ CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
}
- node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
- node);
+ CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
+ build_int_cst (integer_type_node, d->n));
- tmp = build_constructor_from_list (select_struct[k], nreverse (node));
- init = tree_cons (NULL_TREE, tmp, init);
+ tmp = build_constructor (select_struct[k], node);
+ CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
}
type = build_array_type (select_struct[k],
build_index_type (build_int_cst (NULL_TREE, n-1)));
- init = build_constructor_from_list (type, nreverse(init));
+ init = build_constructor (type, inits);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the jump table. */
/* A scalar or derived type. */
/* Determine allocate size. */
- if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+ if (al->expr->ts.type == BT_CLASS && code->expr3)
{
- gfc_expr *sz;
- gfc_se se_sz;
- sz = gfc_copy_expr (code->expr3);
- gfc_add_component_ref (sz, "$vptr");
- gfc_add_component_ref (sz, "$size");
- gfc_init_se (&se_sz, NULL);
- gfc_conv_expr (&se_sz, sz);
- gfc_free_expr (sz);
- memsz = se_sz.expr;
+ if (code->expr3->ts.type == BT_CLASS)
+ {
+ gfc_expr *sz;
+ gfc_se se_sz;
+ sz = gfc_copy_expr (code->expr3);
+ gfc_add_component_ref (sz, "$vptr");
+ gfc_add_component_ref (sz, "$size");
+ gfc_init_se (&se_sz, NULL);
+ gfc_conv_expr (&se_sz, sz);
+ gfc_free_expr (sz);
+ memsz = se_sz.expr;
+ }
+ else
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
}
- else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
- memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
else
gfc_add_expr_to_block (&block, tmp);
/* Initialization via SOURCE block. */
- if (code->expr3)
+ if (code->expr3 && !code->expr3->mold)
{
gfc_expr *rhs = gfc_copy_expr (code->expr3);
if (al->expr->ts.type == BT_CLASS)
rhs = NULL;
if (code->expr3 && code->expr3->ts.type == BT_CLASS)
{
- /* VPTR must be determined at run time. */
+ /* Polymorphic SOURCE: VPTR must be determined at run time. */
rhs = gfc_copy_expr (code->expr3);
gfc_add_component_ref (rhs, "$vptr");
tmp = gfc_trans_pointer_assignment (lhs, rhs);
else if (code->ext.alloc.ts.type == BT_DERIVED)
ts = &code->ext.alloc.ts;
else if (expr->ts.type == BT_CLASS)
- ts = &expr->ts.u.derived->components->ts;
+ ts = &CLASS_DATA (expr)->ts;
else
ts = &expr->ts;
if (ts->type == BT_DERIVED)
{
- vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtab = gfc_find_derived_vtab (ts->u.derived, true);
gcc_assert (vtab);
+ gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
gfc_conv_expr (&lse, lhs);
OSDN Git Service
