#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include <assert.h>
#include <gmp.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"
static GTY(()) tree gfc_pint4_type_node;
static GTY(()) tree ioparm_unit;
static GTY(()) tree ioparm_err;
static GTY(()) tree ioparm_end;
static GTY(()) tree ioparm_eor;
static GTY(()) tree ioparm_list_format;
static GTY(()) tree ioparm_library_return;
static GTY(()) tree ioparm_iostat;
static GTY(()) tree ioparm_exist;
static GTY(()) tree ioparm_opened;
static GTY(()) tree ioparm_number;
static GTY(()) tree ioparm_named;
static GTY(()) tree ioparm_rec;
static GTY(()) tree ioparm_nextrec;
static GTY(()) tree ioparm_size;
static GTY(()) tree ioparm_recl_in;
static GTY(()) tree ioparm_recl_out;
static GTY(()) tree ioparm_file;
static GTY(()) tree ioparm_file_len;
static GTY(()) tree ioparm_status;
static GTY(()) tree ioparm_status_len;
static GTY(()) tree ioparm_access;
static GTY(()) tree ioparm_access_len;
static GTY(()) tree ioparm_form;
static GTY(()) tree ioparm_form_len;
static GTY(()) tree ioparm_blank;
static GTY(()) tree ioparm_blank_len;
static GTY(()) tree ioparm_position;
static GTY(()) tree ioparm_position_len;
static GTY(()) tree ioparm_action;
static GTY(()) tree ioparm_action_len;
static GTY(()) tree ioparm_delim;
static GTY(()) tree ioparm_delim_len;
static GTY(()) tree ioparm_pad;
static GTY(()) tree ioparm_pad_len;
static GTY(()) tree ioparm_format;
static GTY(()) tree ioparm_format_len;
static GTY(()) tree ioparm_advance;
static GTY(()) tree ioparm_advance_len;
static GTY(()) tree ioparm_name;
static GTY(()) tree ioparm_name_len;
static GTY(()) tree ioparm_internal_unit;
static GTY(()) tree ioparm_internal_unit_len;
static GTY(()) tree ioparm_sequential;
static GTY(()) tree ioparm_sequential_len;
static GTY(()) tree ioparm_direct;
static GTY(()) tree ioparm_direct_len;
static GTY(()) tree ioparm_formatted;
static GTY(()) tree ioparm_formatted_len;
static GTY(()) tree ioparm_unformatted;
static GTY(()) tree ioparm_unformatted_len;
static GTY(()) tree ioparm_read;
static GTY(()) tree ioparm_read_len;
static GTY(()) tree ioparm_write;
static GTY(()) tree ioparm_write_len;
static GTY(()) tree ioparm_readwrite;
static GTY(()) tree ioparm_readwrite_len;
static GTY(()) tree ioparm_namelist_name;
static GTY(()) tree ioparm_namelist_name_len;
static GTY(()) tree ioparm_namelist_read_mode;
static GTY(()) tree ioparm_var;
static GTY(()) tree locus_file;
static GTY(()) tree locus_line;
static GTY(()) tree iocall_read;
static GTY(()) tree iocall_read_done;
static GTY(()) tree iocall_write;
static GTY(()) tree iocall_write_done;
static GTY(()) tree iocall_x_integer;
static GTY(()) tree iocall_x_logical;
static GTY(()) tree iocall_x_character;
static GTY(()) tree iocall_x_real;
static GTY(()) tree iocall_x_complex;
static GTY(()) tree iocall_open;
static GTY(()) tree iocall_close;
static GTY(()) tree iocall_inquire;
static GTY(()) tree iocall_rewind;
static GTY(()) tree iocall_backspace;
static GTY(()) tree iocall_endfile;
static GTY(()) tree iocall_set_nml_val_int;
static GTY(()) tree iocall_set_nml_val_float;
static GTY(()) tree iocall_set_nml_val_char;
static GTY(()) tree iocall_set_nml_val_complex;
static GTY(()) tree iocall_set_nml_val_log;
static enum { READ, WRITE } last_dt;
#define ADD_FIELD(name, type) \
ioparm_ ## name = gfc_add_field_to_struct \
(&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
get_identifier (stringize(name)), type)
#define ADD_STRING(name) \
ioparm_ ## name = gfc_add_field_to_struct \
(&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
get_identifier (stringize(name)), pchar_type_node); \
ioparm_ ## name ## _len = gfc_add_field_to_struct \
(&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
get_identifier (stringize(name) "_len"), gfc_int4_type_node)
void
gfc_build_io_library_fndecls (void)
{
tree ioparm_type;
gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
ioparm_type = make_node (RECORD_TYPE);
TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
ADD_FIELD (unit, gfc_int4_type_node);
ADD_FIELD (err, gfc_int4_type_node);
ADD_FIELD (end, gfc_int4_type_node);
ADD_FIELD (eor, gfc_int4_type_node);
ADD_FIELD (list_format, gfc_int4_type_node);
ADD_FIELD (library_return, gfc_int4_type_node);
ADD_FIELD (iostat, gfc_pint4_type_node);
ADD_FIELD (exist, gfc_pint4_type_node);
ADD_FIELD (opened, gfc_pint4_type_node);
ADD_FIELD (number, gfc_pint4_type_node);
ADD_FIELD (named, gfc_pint4_type_node);
ADD_FIELD (rec, gfc_pint4_type_node);
ADD_FIELD (nextrec, gfc_pint4_type_node);
ADD_FIELD (size, gfc_pint4_type_node);
ADD_FIELD (recl_in, gfc_pint4_type_node);
ADD_FIELD (recl_out, gfc_pint4_type_node);
ADD_STRING (file);
ADD_STRING (status);
ADD_STRING (access);
ADD_STRING (form);
ADD_STRING (blank);
ADD_STRING (position);
ADD_STRING (action);
ADD_STRING (delim);
ADD_STRING (pad);
ADD_STRING (format);
ADD_STRING (advance);
ADD_STRING (name);
ADD_STRING (internal_unit);
ADD_STRING (sequential);
ADD_STRING (direct);
ADD_STRING (formatted);
ADD_STRING (unformatted);
ADD_STRING (read);
ADD_STRING (write);
ADD_STRING (readwrite);
ADD_STRING (namelist_name);
ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
gfc_finish_type (ioparm_type);
ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
ioparm_type);
DECL_EXTERNAL (ioparm_var) = 1;
TREE_PUBLIC (ioparm_var) = 1;
locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
gfc_int4_type_node);
DECL_EXTERNAL (locus_line) = 1;
TREE_PUBLIC (locus_line) = 1;
locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
pchar_type_node);
DECL_EXTERNAL (locus_file) = 1;
TREE_PUBLIC (locus_file) = 1;
iocall_x_integer =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_integer")),
void_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
iocall_x_logical =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_logical")),
void_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
iocall_x_character =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_character")),
void_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
iocall_x_real =
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
void_type_node, 2,
pvoid_type_node, gfc_int4_type_node);
iocall_x_complex =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_complex")),
void_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
iocall_read =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
void_type_node, 0);
iocall_write =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
void_type_node, 0);
iocall_open =
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
void_type_node, 0);
iocall_close =
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
void_type_node, 0);
iocall_inquire =
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
gfc_int4_type_node, 0);
iocall_rewind =
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
gfc_int4_type_node, 0);
iocall_backspace =
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
gfc_int4_type_node, 0);
iocall_endfile =
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
gfc_int4_type_node, 0);
iocall_read_done =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
gfc_int4_type_node, 0);
iocall_write_done =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
gfc_int4_type_node, 0);
iocall_set_nml_val_int =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_float =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_char =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_complex =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
iocall_set_nml_val_log =
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
void_type_node, 4,
pvoid_type_node, pvoid_type_node,
gfc_int4_type_node,gfc_int4_type_node);
}
static void
set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
{
gfc_se se;
tree tmp;
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, e, TREE_TYPE (var));
gfc_add_block_to_block (block, &se.pre);
tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var);
gfc_add_modify_expr (block, tmp, se.expr);
}
static void
set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
{
gfc_se se;
tree tmp;
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr_type (&se, e, TREE_TYPE (var));
gfc_add_block_to_block (block, &se.pre);
tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var);
gfc_add_modify_expr (block, tmp, se.expr);
}
static void
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
tree var_len, gfc_expr * e)
{
gfc_se se;
tree tmp;
tree msg;
tree io;
tree len;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, e);
io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var);
len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len);
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
msg =
gfc_build_string_const (37, "Assigned label is not a format label");
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = build (LE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
gfc_trans_runtime_check (tmp, msg, &se.pre);
gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
}
else
{
gfc_conv_string_parameter (&se);
gfc_add_modify_expr (&se.pre, io, se.expr);
gfc_add_modify_expr (&se.pre, len, se.string_length);
}
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
}
static void
set_flag (stmtblock_t *block, tree var)
{
tree tmp;
tmp = build (COMPONENT_REF, TREE_TYPE(var), ioparm_var, var);
gfc_add_modify_expr (block, tmp, integer_one_node);
}
static void
add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
{
tree tmp, value;
if (label == NULL)
return;
value = build_int_2 (label_value, 0);
tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
DECL_CONTEXT (tmp) = current_function_decl;
tmp = build_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
gfc_add_expr_to_block (body, tmp);
tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
gfc_add_expr_to_block (body, tmp);
}
static void
io_result (stmtblock_t * block, gfc_st_label * err_label,
gfc_st_label * end_label, gfc_st_label * eor_label)
{
stmtblock_t body;
tree tmp, rc;
if (err_label == NULL
&& end_label == NULL
&& eor_label == NULL)
return;
gfc_start_block (&body);
add_case (1, err_label, &body);
add_case (2, end_label, &body);
add_case (3, eor_label, &body);
tmp = gfc_finish_block (&body);
rc = build (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
ioparm_library_return);
tmp = build_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
gfc_add_expr_to_block (block, tmp);
}
static void
set_error_locus (stmtblock_t * block, locus * where)
{
gfc_file *f;
tree tmp;
int line;
f = where->lb->file;
tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename);
tmp = gfc_build_addr_expr (pchar_type_node, tmp);
gfc_add_modify_expr (block, locus_file, tmp);
line = where->lb->linenum;
gfc_add_modify_expr (block, locus_line, build_int_2 (line, 0));
}
tree
gfc_trans_open (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_open *p;
tree tmp;
gfc_init_block (&block);
gfc_init_block (&post_block);
set_error_locus (&block, &code->loc);
p = code->ext.open;
if (p->unit)
set_parameter_value (&block, ioparm_unit, p->unit);
if (p->file)
set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
if (p->status)
set_string (&block, &post_block, ioparm_status,
ioparm_status_len, p->status);
if (p->access)
set_string (&block, &post_block, ioparm_access,
ioparm_access_len, p->access);
if (p->form)
set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
if (p->recl)
set_parameter_value (&block, ioparm_recl_in, p->recl);
if (p->blank)
set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
p->blank);
if (p->position)
set_string (&block, &post_block, ioparm_position,
ioparm_position_len, p->position);
if (p->action)
set_string (&block, &post_block, ioparm_action,
ioparm_action_len, p->action);
if (p->delim)
set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
p->delim);
if (p->pad)
set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
if (p->iostat)
set_parameter_ref (&block, ioparm_iostat, p->iostat);
if (p->err)
set_flag (&block, ioparm_err);
tmp = gfc_build_function_call (iocall_open, NULL_TREE);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
io_result (&block, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
tree
gfc_trans_close (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_close *p;
tree tmp;
gfc_init_block (&block);
gfc_init_block (&post_block);
set_error_locus (&block, &code->loc);
p = code->ext.close;
if (p->unit)
set_parameter_value (&block, ioparm_unit, p->unit);
if (p->status)
set_string (&block, &post_block, ioparm_status,
ioparm_status_len, p->status);
if (p->iostat)
set_parameter_ref (&block, ioparm_iostat, p->iostat);
if (p->err)
set_flag (&block, ioparm_err);
tmp = gfc_build_function_call (iocall_close, NULL_TREE);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
io_result (&block, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
static tree
build_filepos (tree function, gfc_code * code)
{
stmtblock_t block;
gfc_filepos *p;
tree tmp;
p = code->ext.filepos;
gfc_init_block (&block);
set_error_locus (&block, &code->loc);
if (p->unit)
set_parameter_value (&block, ioparm_unit, p->unit);
if (p->iostat)
set_parameter_ref (&block, ioparm_iostat, p->iostat);
if (p->err)
set_flag (&block, ioparm_err);
tmp = gfc_build_function_call (function, NULL);
gfc_add_expr_to_block (&block, tmp);
io_result (&block, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
tree
gfc_trans_backspace (gfc_code * code)
{
return build_filepos (iocall_backspace, code);
}
tree
gfc_trans_endfile (gfc_code * code)
{
return build_filepos (iocall_endfile, code);
}
tree
gfc_trans_rewind (gfc_code * code)
{
return build_filepos (iocall_rewind, code);
}
tree
gfc_trans_inquire (gfc_code * code)
{
stmtblock_t block, post_block;
gfc_inquire *p;
tree tmp;
gfc_init_block (&block);
gfc_init_block (&post_block);
set_error_locus (&block, &code->loc);
p = code->ext.inquire;
if (p->unit)
set_parameter_value (&block, ioparm_unit, p->unit);
if (p->file)
set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
if (p->iostat)
set_parameter_ref (&block, ioparm_iostat, p->iostat);
if (p->exist)
set_parameter_ref (&block, ioparm_exist, p->exist);
if (p->opened)
set_parameter_ref (&block, ioparm_opened, p->opened);
if (p->number)
set_parameter_ref (&block, ioparm_number, p->number);
if (p->named)
set_parameter_ref (&block, ioparm_named, p->named);
if (p->name)
set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
if (p->access)
set_string (&block, &post_block, ioparm_access,
ioparm_access_len, p->access);
if (p->sequential)
set_string (&block, &post_block, ioparm_sequential,
ioparm_sequential_len, p->sequential);
if (p->direct)
set_string (&block, &post_block, ioparm_direct,
ioparm_direct_len, p->direct);
if (p->form)
set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
if (p->formatted)
set_string (&block, &post_block, ioparm_formatted,
ioparm_formatted_len, p->formatted);
if (p->unformatted)
set_string (&block, &post_block, ioparm_unformatted,
ioparm_unformatted_len, p->unformatted);
if (p->recl)
set_parameter_ref (&block, ioparm_recl_out, p->recl);
if (p->nextrec)
set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
if (p->blank)
set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
p->blank);
if (p->position)
set_string (&block, &post_block, ioparm_position,
ioparm_position_len, p->position);
if (p->action)
set_string (&block, &post_block, ioparm_action,
ioparm_action_len, p->action);
if (p->read)
set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
if (p->write)
set_string (&block, &post_block, ioparm_write,
ioparm_write_len, p->write);
if (p->readwrite)
set_string (&block, &post_block, ioparm_readwrite,
ioparm_readwrite_len, p->readwrite);
if (p->delim)
set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
p->delim);
if (p->err)
set_flag (&block, ioparm_err);
tmp = gfc_build_function_call (iocall_inquire, NULL);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
io_result (&block, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
tree
gfc_trans_iolength (gfc_code * c ATTRIBUTE_UNUSED)
{
gfc_todo_error ("IOLENGTH statement");
}
static gfc_expr *
gfc_new_nml_name_expr (char * name)
{
gfc_expr * nml_name;
nml_name = gfc_get_expr();
nml_name->ref = NULL;
nml_name->expr_type = EXPR_CONSTANT;
nml_name->ts.kind = gfc_default_character_kind ();
nml_name->ts.type = BT_CHARACTER;
nml_name->value.character.length = strlen(name);
nml_name->value.character.string = name;
return nml_name;
}
static gfc_expr *
get_new_var_expr(gfc_symbol * sym)
{
gfc_expr * nml_var;
nml_var = gfc_get_expr();
nml_var->expr_type = EXPR_VARIABLE;
nml_var->ts = sym->ts;
if (sym->as)
nml_var->rank = sym->as->rank;
nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
nml_var->symtree->n.sym = sym;
nml_var->where = sym->declared_at;
sym->attr.referenced = 1;
return nml_var;
}
static tree
build_dt (tree * function, gfc_code * code)
{
stmtblock_t block, post_block;
gfc_dt *dt;
tree tmp, args, arg2;
gfc_expr *nmlname, *nmlvar;
gfc_namelist *nml, *nml_tail;
gfc_se se,se2;
int ts_kind, ts_type, name_len;
gfc_init_block (&block);
gfc_init_block (&post_block);
set_error_locus (&block, &code->loc);
dt = code->ext.dt;
if (dt->io_unit)
{
if (dt->io_unit->ts.type == BT_CHARACTER)
{
set_string (&block, &post_block, ioparm_internal_unit,
ioparm_internal_unit_len, dt->io_unit);
}
else
set_parameter_value (&block, ioparm_unit, dt->io_unit);
}
if (dt->rec)
set_parameter_value (&block, ioparm_rec, dt->rec);
if (dt->advance)
set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
dt->advance);
if (dt->format_expr)
set_string (&block, &post_block, ioparm_format, ioparm_format_len,
dt->format_expr);
if (dt->format_label)
{
if (dt->format_label == &format_asterisk)
set_flag (&block, ioparm_list_format);
else
set_string (&block, &post_block, ioparm_format,
ioparm_format_len, dt->format_label->format);
}
if (dt->iostat)
set_parameter_ref (&block, ioparm_iostat, dt->iostat);
if (dt->size)
set_parameter_ref (&block, ioparm_size, dt->size);
if (dt->err)
set_flag (&block, ioparm_err);
if (dt->eor)
set_flag(&block, ioparm_eor);
if (dt->end)
set_flag(&block, ioparm_end);
if (dt->namelist)
{
if (dt->format_expr || dt->format_label)
fatal_error("A format cannot be specified with a namelist");
nmlname = gfc_new_nml_name_expr(dt->namelist->name);
set_string (&block, &post_block, ioparm_namelist_name,
ioparm_namelist_name_len, nmlname);
if (last_dt == READ)
set_flag (&block, ioparm_namelist_read_mode);
nml = dt->namelist->namelist;
nml_tail = dt->namelist->namelist_tail;
while(nml != NULL)
{
gfc_init_se (&se, NULL);
gfc_init_se (&se2, NULL);
nmlvar = get_new_var_expr(nml->sym);
nmlname = gfc_new_nml_name_expr(nml->sym->name);
name_len = strlen(nml->sym->name);
ts_kind = nml->sym->ts.kind;
ts_type = nml->sym->ts.type;
gfc_conv_expr_reference (&se2, nmlname);
gfc_conv_expr_reference (&se, nmlvar);
args = gfc_chainon_list (NULL_TREE, se.expr);
args = gfc_chainon_list (args, se2.expr);
args = gfc_chainon_list (args, se2.string_length);
arg2 = build_int_2 (ts_kind, 0);
args = gfc_chainon_list (args,arg2);
switch (ts_type)
{
case BT_INTEGER:
tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
break;
case BT_CHARACTER:
tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
break;
case BT_REAL:
tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
break;
case BT_LOGICAL:
tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
break;
case BT_COMPLEX:
tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
break;
default :
internal_error ("Bad namelist IO basetype (%d)", ts_type);
}
gfc_add_expr_to_block (&block, tmp);
nml = nml->next;
}
}
tmp = gfc_build_function_call (*function, NULL_TREE);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
return gfc_finish_block (&block);
}
tree
gfc_trans_read (gfc_code * code)
{
last_dt = READ;
return build_dt (&iocall_read, code);
}
tree
gfc_trans_write (gfc_code * code)
{
last_dt = WRITE;
return build_dt (&iocall_write, code);
}
tree
gfc_trans_dt_end (gfc_code * code)
{
tree function, tmp;
stmtblock_t block;
gfc_init_block (&block);
function = (last_dt == READ) ? iocall_read_done : iocall_write_done;
tmp = gfc_build_function_call (function, NULL);
gfc_add_expr_to_block (&block, tmp);
io_result (&block, code->ext.dt->err, code->ext.dt->end, code->ext.dt->eor);
return gfc_finish_block (&block);
}
static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
{
tree args, tmp, function, arg2, field, expr;
gfc_component *c;
int kind;
kind = ts->kind;
function = NULL;
arg2 = NULL;
switch (ts->type)
{
case BT_INTEGER:
arg2 = build_int_2 (kind, 0);
function = iocall_x_integer;
break;
case BT_REAL:
arg2 = build_int_2 (kind, 0);
function = iocall_x_real;
break;
case BT_COMPLEX:
arg2 = build_int_2 (kind, 0);
function = iocall_x_complex;
break;
case BT_LOGICAL:
arg2 = build_int_2 (kind, 0);
function = iocall_x_logical;
break;
case BT_CHARACTER:
arg2 = se->string_length;
function = iocall_x_character;
break;
case BT_DERIVED:
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = gfc_build_indirect_ref (expr);
for (c = ts->derived->components; c; c = c->next)
{
field = c->backend_decl;
assert (field && TREE_CODE (field) == FIELD_DECL);
tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field);
if (c->ts.type == BT_CHARACTER)
{
assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
se->string_length =
TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
transfer_expr (se, &c->ts, gfc_build_addr_expr (NULL, tmp));
}
return;
default:
internal_error ("Bad IO basetype (%d)", ts->type);
}
args = gfc_chainon_list (NULL_TREE, addr_expr);
args = gfc_chainon_list (args, arg2);
tmp = gfc_build_function_call (function, args);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
}
tree
gfc_trans_transfer (gfc_code * code)
{
stmtblock_t block, body;
gfc_loopinfo loop;
gfc_expr *expr;
gfc_ss *ss;
gfc_se se;
tree tmp;
gfc_start_block (&block);
expr = code->expr;
ss = gfc_walk_expr (expr);
gfc_init_se (&se, NULL);
if (ss == gfc_ss_terminator)
gfc_init_block (&body);
else
{
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
}
gfc_conv_expr_reference (&se, expr);
transfer_expr (&se, &expr->ts, se.expr);
gfc_add_block_to_block (&body, &se.pre);
gfc_add_block_to_block (&body, &se.post);
if (se.ss == NULL)
tmp = gfc_finish_block (&body);
else
{
assert (se.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&loop.pre, &loop.post);
tmp = gfc_finish_block (&loop.pre);
gfc_cleanup_loop (&loop);
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);;
}
#include "gt-fortran-trans-io.h"