#include "trans-types.h"
#include "trans-const.h"
-
/* Members of the ioparm structure. */
enum ioparam_type
enum iofield_type
{
IOPARM_type_int4,
+ IOPARM_type_intio,
IOPARM_type_pint4,
+ IOPARM_type_pintio,
IOPARM_type_pchar,
IOPARM_type_parray,
IOPARM_type_pad,
gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
- len);
+ len + 1);
TYPE_NAME (t) = get_identifier (name);
for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
switch (p->type)
{
case IOPARM_type_int4:
+ case IOPARM_type_intio:
case IOPARM_type_pint4:
+ case IOPARM_type_pintio:
case IOPARM_type_parray:
case IOPARM_type_pchar:
case IOPARM_type_pad:
gfc_build_io_library_fndecls (void)
{
tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+ tree gfc_intio_type_node;
tree parm_type, dt_parm_type;
tree gfc_c_int_type_node;
HOST_WIDE_INT pad_size;
enum ioparam_type ptype;
types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+ types[IOPARM_type_intio] = gfc_intio_type_node
+ = gfc_get_int_type (gfc_intio_kind);
types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+ types[IOPARM_type_pintio]
+ = build_pointer_type (gfc_intio_type_node);
types[IOPARM_type_parray] = pchar_type_node;
types[IOPARM_type_pchar] = pchar_type_node;
pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
+
+ /* pad actually contains pointers and integers so it needs to have an
+ alignment that is at least as large as the needed alignment for those
+ types. See the st_parameter_dt structure in libgfortran/io/io.h for
+ what really goes into this space. */
+ TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
+ TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind)));
+
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
if (TYPE_MODE (TREE_TYPE (se.expr))
== TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
addr = convert (TREE_TYPE (p->field),
- gfc_build_addr_expr (NULL, se.expr));
+ build_fold_addr_expr (se.expr));
else
{
/* The type used by the library has different size
tree tmpvar
= gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
st_parameter_field[type].name);
- addr = gfc_build_addr_expr (NULL, tmpvar);
+ addr = build_fold_addr_expr (tmpvar);
tmp = convert (TREE_TYPE (se.expr), tmpvar);
gfc_add_modify_expr (postblock, se.expr, tmp);
}
{
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
TREE_OPERAND (se->expr, 1));
- se->expr = gfc_build_addr_expr (NULL, se->expr);
+ se->expr = build_fold_addr_expr (se->expr);
}
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
{
gfc_se se;
tree tmp;
- tree msg;
tree io;
tree len;
gfc_st_parameter_field *p = &st_parameter_field[type];
/* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
+ char * msg;
+
gfc_conv_label_variable (&se, e);
- msg =
- gfc_build_cstring_const ("Assigned label is not a format label");
tmp = GFC_DECL_STRING_LEN (se.expr);
- tmp = build2 (LE_EXPR, boolean_type_node,
- tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
- gfc_trans_runtime_check (tmp, msg, &se.pre);
+ tmp = fold_build2 (LT_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+
+ asprintf(&msg, "Label assigned to variable '%s' is not a format label",
+ e->symtree->name);
+ gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where);
+ gfc_free (msg);
+
gfc_add_modify_expr (&se.pre, io,
fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
gfc_conv_expr (&se, e);
gfc_conv_string_parameter (&se);
tmp = se.expr;
- se.expr = fold_convert (pchar_type_node, integer_zero_node);
+ se.expr = build_int_cst (pchar_type_node, 0);
}
/* Character array. */
- else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
+ else if (e->rank > 0)
{
se.ss = gfc_walk_expr (e);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_fold_addr_expr (var);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp);
+ tmp = build_function_call_expr (iocall[IOCALL_OPEN], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_fold_addr_expr (var);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp);
+ tmp = build_function_call_expr (iocall[IOCALL_CLOSE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_fold_addr_expr (var);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (function, tmp);
+ tmp = build_function_call_expr (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
p->convert);
+ if (p->strm_pos)
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_strm_pos_out, p->strm_pos);
+
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_fold_addr_expr (var);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (iocall[IOCALL_INQUIRE], tmp);
+ tmp = build_function_call_expr (iocall[IOCALL_INQUIRE], tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
- itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
+ itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
/* If an array, set flag and use indirect ref. if built. */
/* Now build the address expression. */
- tmp = gfc_build_addr_expr (NULL, tmp);
+ tmp = build_fold_addr_expr (tmp);
/* If scalar dummy, resolve indirect reference now. */
if (dummy_arg_flagged && !array_flagged)
- tmp = gfc_build_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref (tmp);
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
The call for the scalar part transfers:
(address, name, type, kind or string_length, dtype) */
- dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ dt_parm_addr = build_fold_addr_expr (dt_parm);
NML_FIRST_ARG (dt_parm_addr);
NML_ADD_ARG (addr_expr);
NML_ADD_ARG (string);
if (ts->type == BT_CHARACTER)
NML_ADD_ARG (ts->cl->backend_decl);
else
- NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
+ NML_ADD_ARG (build_int_cst (gfc_charlen_type_node, 0));
NML_ADD_ARG (dtype);
- tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL], args);
+ tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL], args);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
- tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL_DIM], args);
+ tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], args);
gfc_add_expr_to_block (block, tmp);
}
/* Provide the RECORD_TYPE to build component references. */
- tree expr = gfc_build_indirect_ref (addr_expr);
+ tree expr = build_fold_indirect_ref (addr_expr);
for (cmp = ts->derived->components; cmp; cmp = cmp->next)
{
else
set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_fold_addr_expr (var);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (function, tmp);
+ tmp = build_function_call_expr (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
gcc_unreachable ();
}
- tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_fold_addr_expr (dt_parm);
tmp = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (function, tmp);
+ tmp = build_function_call_expr (function, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, dt_post_end_block);
gfc_init_block (dt_post_end_block);
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
- tmp = gfc_build_addr_expr (NULL, se.expr);
+ tmp = build_fold_addr_expr (se.expr);
transfer_expr (&se, &cm->ts, tmp);
/* We are done now with the loop body. Wrap up the scalarizer and
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
if (se->string_length)
arg2 = se->string_length;
else
{
- tmp = gfc_build_indirect_ref (addr_expr);
+ tmp = build_fold_indirect_ref (addr_expr);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
case BT_DERIVED:
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
- expr = gfc_build_indirect_ref (expr);
+ expr = build_fold_indirect_ref (expr);
for (c = ts->derived->components; c; c = c->next)
{
else
{
if (!c->pointer)
- tmp = gfc_build_addr_expr (NULL, tmp);
+ tmp = build_fold_addr_expr (tmp);
transfer_expr (se, &c->ts, tmp);
}
}
internal_error ("Bad IO basetype (%d)", ts->type);
}
- tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_fold_addr_expr (dt_parm);
args = gfc_chainon_list (NULL_TREE, tmp);
args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, arg2);
- tmp = gfc_build_function_call (function, args);
+ tmp = build_function_call_expr (function, args);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
kind_arg = build_int_cst (NULL_TREE, ts->kind);
- tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_fold_addr_expr (dt_parm);
args = gfc_chainon_list (NULL_TREE, tmp);
args = gfc_chainon_list (args, addr_expr);
args = gfc_chainon_list (args, kind_arg);
args = gfc_chainon_list (args, charlen_arg);
- tmp = gfc_build_function_call (iocall[IOCALL_X_ARRAY], args);
+ tmp = build_function_call_expr (iocall[IOCALL_X_ARRAY], args);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
}
{
/* Get the descriptor. */
gfc_conv_expr_descriptor (&se, expr, ss);
- tmp = gfc_build_addr_expr (NULL, se.expr);
+ tmp = build_fold_addr_expr (se.expr);
transfer_array_desc (&se, &expr->ts, tmp);
goto finish_block_label;
}
OSDN Git Service
