#include "proj.h"
#include "rtl.h"
#include "toplev.h"
#include "ggc.h"
#include "ste.h"
#include "bld.h"
#include "com.h"
#include "expr.h"
#include "lab.h"
#include "lex.h"
#include "sta.h"
#include "stp.h"
#include "str.h"
#include "sts.h"
#include "stt.h"
#include "stv.h"
#include "stw.h"
#include "symbol.h"
typedef enum
{
FFESTE_stateletSIMPLE_,
FFESTE_stateletATTRIB_,
FFESTE_stateletITEM_,
FFESTE_stateletITEMVALS_,
FFESTE_
} ffesteStatelet_;
static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
static ffelab ffeste_label_formatdef_ = NULL;
static tree (*ffeste_io_driver_) (ffebld expr);
static ffecomGfrt ffeste_io_endgfrt_;
static tree ffeste_io_abort_;
static bool ffeste_io_abort_is_temp_;
static tree ffeste_io_end_;
static tree ffeste_io_err_;
static tree ffeste_io_iostat_;
static bool ffeste_io_iostat_is_temp_;
static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
tree *xitersvar, ffebld var,
ffebld start, ffelexToken start_token,
ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token,
const char *msg);
static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
tree itersvar);
static void ffeste_io_call_ (tree call, bool do_check);
static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
static tree ffeste_io_dofio_ (ffebld expr);
static tree ffeste_io_dolio_ (ffebld expr);
static tree ffeste_io_douio_ (ffebld expr);
static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
ffebld unit_expr, int unit_dflt);
static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
ffebld unit_expr, int unit_dflt,
bool have_end, ffestvFormat format,
ffestpFile *format_spec, bool rec,
ffebld rec_expr);
static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
ffestpFile *stat_spec);
static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
bool have_end, ffestvFormat format,
ffestpFile *format_spec);
static tree ffeste_io_inlist_ (bool have_err,
ffestpFile *unit_spec,
ffestpFile *file_spec,
ffestpFile *exist_spec,
ffestpFile *open_spec,
ffestpFile *number_spec,
ffestpFile *named_spec,
ffestpFile *name_spec,
ffestpFile *access_spec,
ffestpFile *sequential_spec,
ffestpFile *direct_spec,
ffestpFile *form_spec,
ffestpFile *formatted_spec,
ffestpFile *unformatted_spec,
ffestpFile *recl_spec,
ffestpFile *nextrec_spec,
ffestpFile *blank_spec);
static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
ffestpFile *file_spec,
ffestpFile *stat_spec,
ffestpFile *access_spec,
ffestpFile *form_spec,
ffestpFile *recl_spec,
ffestpFile *blank_spec);
static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
#define ffeste_emit_line_note_() \
emit_line_note (input_filename, lineno)
#define ffeste_check_simple_() \
assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
#define ffeste_check_start_() \
assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
ffeste_statelet_ = FFESTE_stateletATTRIB_
#define ffeste_check_attrib_() \
assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
#define ffeste_check_item_() \
assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
|| ffeste_statelet_ == FFESTE_stateletITEM_); \
ffeste_statelet_ = FFESTE_stateletITEM_
#define ffeste_check_item_startvals_() \
assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
|| ffeste_statelet_ == FFESTE_stateletITEM_); \
ffeste_statelet_ = FFESTE_stateletITEMVALS_
#define ffeste_check_item_value_() \
assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
#define ffeste_check_item_endvals_() \
assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
ffeste_statelet_ = FFESTE_stateletITEM_
#define ffeste_check_finish_() \
assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
|| ffeste_statelet_ == FFESTE_stateletITEM_); \
ffeste_statelet_ = FFESTE_stateletSIMPLE_
#define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
do \
{ \
if ((Spec)->kw_or_val_present) \
Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
else \
Exp = null_pointer_node; \
if (Exp) \
Init = Exp; \
else \
{ \
Init = null_pointer_node; \
constantp = FALSE; \
} \
} while(0)
#define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
do \
{ \
if ((Spec)->kw_or_val_present) \
Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
else \
{ \
Exp = null_pointer_node; \
Lenexp = ffecom_f2c_ftnlen_zero_node; \
} \
if (Exp) \
Init = Exp; \
else \
{ \
Init = null_pointer_node; \
constantp = FALSE; \
} \
if (Lenexp) \
Leninit = Lenexp; \
else \
{ \
Leninit = ffecom_f2c_ftnlen_zero_node; \
constantp = FALSE; \
} \
} while(0)
#define ffeste_f2c_init_flag_(Flag,Init) \
do \
{ \
Init = convert (ffecom_f2c_flag_type_node, \
(Flag) ? integer_one_node : integer_zero_node); \
} while(0)
#define ffeste_f2c_init_format_(Exp,Init,Spec) \
do \
{ \
Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
if (Exp) \
Init = Exp; \
else \
{ \
Init = null_pointer_node; \
constantp = FALSE; \
} \
} while(0)
#define ffeste_f2c_init_int_(Exp,Init,Spec) \
do \
{ \
if ((Spec)->kw_or_val_present) \
Exp = ffecom_const_expr ((Spec)->u.expr); \
else \
Exp = ffecom_integer_zero_node; \
if (Exp) \
Init = Exp; \
else \
{ \
Init = ffecom_integer_zero_node; \
constantp = FALSE; \
} \
} while(0)
#define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
do \
{ \
if ((Spec)->kw_or_val_present) \
Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
else \
Exp = null_pointer_node; \
if (Exp) \
Init = Exp; \
else \
{ \
Init = null_pointer_node; \
constantp = FALSE; \
} \
} while(0)
#define ffeste_f2c_init_next_(Init) \
do \
{ \
TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
(Init)); \
initn = TREE_CHAIN(initn); \
} while(0)
#define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
do \
{ \
if (! (Exp)) \
ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
} while(0)
#define ffeste_f2c_prepare_char_(Spec,Exp) \
do \
{ \
if (! (Exp)) \
ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
} while(0)
#define ffeste_f2c_prepare_format_(Spec,Exp) \
do \
{ \
if (! (Exp)) \
ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
} while(0)
#define ffeste_f2c_prepare_int_(Spec,Exp) \
do \
{ \
if (! (Exp)) \
ffecom_prepare_expr ((Spec)->u.expr); \
} while(0)
#define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
do \
{ \
if (! (Exp)) \
ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
} while(0)
#define ffeste_f2c_compile_(Field,Exp) \
do \
{ \
tree exz; \
if ((Exp)) \
{ \
exz = ffecom_modify (void_type_node, \
ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
t, (Field)), \
(Exp)); \
expand_expr_stmt (exz); \
} \
} while(0)
#define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
do \
{ \
tree exq; \
if (! (Exp)) \
{ \
exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
#define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
do \
{ \
tree exq = (Exp); \
tree lenexq = (Lenexp); \
int need_exq = (! exq); \
int need_lenexq = (! lenexq); \
if (need_exq || need_lenexq) \
{ \
exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
if (need_exq) \
ffeste_f2c_compile_ ((Field), exq); \
if (need_lenexq) \
ffeste_f2c_compile_ ((Lenfield), lenexq); \
} \
} while(0)
#define ffeste_f2c_compile_format_(Field,Spec,Exp) \
do \
{ \
tree exq; \
if (! (Exp)) \
{ \
exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
#define ffeste_f2c_compile_int_(Field,Spec,Exp) \
do \
{ \
tree exq; \
if (! (Exp)) \
{ \
exq = ffecom_expr ((Spec)->u.expr); \
ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
#define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
do \
{ \
tree exq; \
if (! (Exp)) \
{ \
exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
ffeste_f2c_compile_ ((Field), exq); \
} \
} while(0)
#ifdef ENABLE_CHECKING
typedef struct gbe_block
{
struct gbe_block *outer;
ffestw block;
int lineno;
const char *input_filename;
bool is_stmt;
} *gbe_block;
gbe_block ffeste_top_block_ = NULL;
static void
ffeste_start_block_ (ffestw block)
{
gbe_block b = xmalloc (sizeof (*b));
b->outer = ffeste_top_block_;
b->block = block;
b->lineno = lineno;
b->input_filename = input_filename;
b->is_stmt = FALSE;
ffeste_top_block_ = b;
ffecom_start_compstmt ();
}
static void
ffeste_end_block_ (ffestw block)
{
gbe_block b = ffeste_top_block_;
assert (b);
assert (! b->is_stmt);
assert (b->block == block);
assert (! b->is_stmt);
ffeste_top_block_ = b->outer;
free (b);
ffecom_end_compstmt ();
}
static void
ffeste_start_stmt_(void)
{
gbe_block b = xmalloc (sizeof (*b));
b->outer = ffeste_top_block_;
b->block = NULL;
b->lineno = lineno;
b->input_filename = input_filename;
b->is_stmt = TRUE;
ffeste_top_block_ = b;
ffecom_start_compstmt ();
}
static void
ffeste_end_stmt_(void)
{
gbe_block b = ffeste_top_block_;
assert (b);
assert (b->is_stmt);
ffeste_top_block_ = b->outer;
free (b);
ffecom_end_compstmt ();
}
#else
#define ffeste_start_block_(b) ffecom_start_compstmt ()
#define ffeste_end_block_(b) \
do \
{ \
ffecom_end_compstmt (); \
} while(0)
#define ffeste_start_stmt_() ffeste_start_block_(NULL)
#define ffeste_end_stmt_() ffeste_end_block_(NULL)
#endif
static void
ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
tree *xitersvar, ffebld var,
ffebld start, ffelexToken start_token,
ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token,
const char *msg)
{
tree tvar;
tree expr;
tree tstart;
tree tend;
tree tincr;
tree tincr_saved;
tree niters;
struct nesting *expanded_loop;
if (block)
ffeste_start_block_ (block);
else
ffeste_start_stmt_ ();
niters = ffecom_make_tempvar (block ? "do" : "impdo",
ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
ffecom_prepare_expr (incr);
ffecom_prepare_expr_rw (NULL_TREE, var);
ffecom_prepare_end ();
tvar = ffecom_expr_rw (NULL_TREE, var);
tincr = ffecom_expr (incr);
if (TREE_CODE (tvar) == ERROR_MARK
|| TREE_CODE (tincr) == ERROR_MARK)
{
if (block)
{
ffeste_end_block_ (block);
ffestw_set_do_tvar (block, error_mark_node);
}
else
{
ffeste_end_stmt_ ();
*xtvar = error_mark_node;
}
return;
}
if (integer_zerop (tincr) || real_zerop (tincr))
{
ffebad_start (FFEBAD_DO_STEP_ZERO);
ffebad_here (0, ffelex_token_where_line (incr_token),
ffelex_token_where_column (incr_token));
ffebad_string (msg);
ffebad_finish ();
tincr = convert (TREE_TYPE (tvar), integer_one_node);
}
tincr_saved = ffecom_save_tree (tincr);
ffeste_start_stmt_ ();
ffecom_prepare_expr (start);
ffecom_prepare_expr (end);
ffecom_prepare_end ();
tstart = ffecom_expr (start);
tend = ffecom_expr (end);
if (TREE_CODE (tstart) == ERROR_MARK
|| TREE_CODE (tend) == ERROR_MARK)
{
ffeste_end_stmt_ ();
if (block)
{
ffeste_end_block_ (block);
ffestw_set_do_tvar (block, error_mark_node);
}
else
{
ffeste_end_stmt_ ();
*xtvar = error_mark_node;
}
return;
}
{
tree try;
if (! ffe_is_onetrip ())
{
try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
tend,
tstart);
try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
try,
tincr);
if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
tincr);
else
try = convert (integer_type_node,
ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
try,
tincr));
try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
try,
convert (TREE_TYPE (tvar),
integer_zero_node)));
if (integer_onep (try))
{
ffebad_start (FFEBAD_DO_NULL);
ffebad_here (0, ffelex_token_where_line (start_token),
ffelex_token_where_column (start_token));
ffebad_string (msg);
ffebad_finish ();
}
}
try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
tend,
tincr);
if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
&& TREE_CONSTANT_OVERFLOW (try))
{
ffebad_start (FFEBAD_DO_END_OVERFLOW);
ffebad_here (0, ffelex_token_where_line (end_token),
ffelex_token_where_column (end_token));
ffebad_string (msg);
ffebad_finish ();
}
}
tstart = ffecom_save_tree (tstart);
expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
tend,
tstart);
if (! ffe_is_onetrip ())
{
expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
expr,
convert (TREE_TYPE (expr), tincr_saved));
}
if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
expr,
tincr_saved);
else
expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
expr,
tincr_saved);
#if 1
if (TREE_TYPE (tvar) != error_mark_node)
expr = convert (ffecom_integer_type_node, expr);
#else
if ((TREE_TYPE (tvar) != error_mark_node)
&& ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
|| ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
&& ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
!= INTEGER_CST)
|| (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
<= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
expr = convert (ffecom_integer_type_node, expr);
#endif
assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
== TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
expr = ffecom_modify (void_type_node, niters, expr);
expand_expr_stmt (expr);
expr = ffecom_modify (void_type_node, tvar, tstart);
expand_expr_stmt (expr);
ffeste_end_stmt_ ();
expanded_loop = expand_start_loop_continue_elsewhere (!! block);
if (block)
ffestw_set_do_hook (block, expanded_loop);
if (! ffe_is_onetrip ())
{
expr = ffecom_truth_value
(ffecom_2 (GE_EXPR, integer_type_node,
ffecom_2 (PREDECREMENT_EXPR,
TREE_TYPE (niters),
niters,
convert (TREE_TYPE (niters),
ffecom_integer_one_node)),
convert (TREE_TYPE (niters),
ffecom_integer_zero_node)));
expand_exit_loop_top_cond (0, expr);
}
if (block)
{
ffestw_set_do_tvar (block, tvar);
ffestw_set_do_incr_saved (block, tincr_saved);
ffestw_set_do_count_var (block, niters);
}
else
{
*xtvar = tvar;
*xtincr = tincr_saved;
*xitersvar = niters;
}
}
static void
ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
{
tree expr;
tree niters = itersvar;
if (tvar == error_mark_node)
return;
expand_loop_continue_here ();
ffeste_start_stmt_ ();
if (ffe_is_onetrip ())
{
expr = ffecom_truth_value
(ffecom_2 (GE_EXPR, integer_type_node,
ffecom_2 (PREDECREMENT_EXPR,
TREE_TYPE (niters),
niters,
convert (TREE_TYPE (niters),
ffecom_integer_one_node)),
convert (TREE_TYPE (niters),
ffecom_integer_zero_node)));
expand_exit_loop_if_false (0, expr);
}
expr = ffecom_modify (void_type_node, tvar,
ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
tvar,
tincr));
expand_expr_stmt (expr);
ffeste_end_stmt_ ();
expand_end_loop ();
if (block)
ffeste_end_block_ (block);
else
ffeste_end_stmt_ ();
}
static void
ffeste_io_call_ (tree call, bool do_check)
{
TREE_SIDE_EFFECTS (call) = 1;
if (ffeste_io_iostat_ != NULL_TREE)
call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
ffeste_io_iostat_, call);
expand_expr_stmt (call);
if (! do_check
|| ffeste_io_abort_ == NULL_TREE
|| TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
return;
expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
expand_goto (ffeste_io_abort_);
expand_end_cond ();
}
static void
ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
{
ffebld var = ffebld_head (ffebld_right (impdo));
ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
ffebld end = ffebld_head (ffebld_trail (ffebld_trail
(ffebld_right (impdo))));
ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
(ffebld_trail (ffebld_right (impdo)))));
ffebld list;
ffebld item;
tree tvar;
tree tincr;
tree titervar;
if (incr == NULL)
{
incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
ffebld_set_info (incr, ffeinfo_new
(FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
}
start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
FFEEXPR_contextLET);
end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
FFEEXPR_contextLET);
incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
FFEEXPR_contextLET);
ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
start, impdo_token,
end, impdo_token,
incr, impdo_token,
"Implied DO loop");
for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
{
item = ffebld_head (list);
if (item == NULL)
continue;
while (ffebld_op (item) == FFEBLD_opPAREN)
item = ffebld_left (item);
if (ffebld_op (item) == FFEBLD_opANY)
continue;
if (ffebld_op (item) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (item, impdo_token);
else
{
ffeste_start_stmt_ ();
ffecom_prepare_arg_ptr_to_expr (item);
ffecom_prepare_end ();
ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
ffeste_end_stmt_ ();
}
}
ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
}
static tree
ffeste_io_dofio_ (ffebld expr)
{
tree num_elements;
tree variable;
tree size;
tree arglist;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
bool is_complex;
bt = ffeinfo_basictype (ffebld_info (expr));
kt = ffeinfo_kindtype (ffebld_info (expr));
if ((bt == FFEINFO_basictypeANY)
|| (kt == FFEINFO_kindtypeANY))
return error_mark_node;
if (bt == FFEINFO_basictypeCOMPLEX)
{
is_complex = TRUE;
bt = FFEINFO_basictypeREAL;
}
else
is_complex = FALSE;
variable = ffecom_arg_ptr_to_expr (expr, &size);
if ((variable == error_mark_node)
|| (size == error_mark_node))
return error_mark_node;
if (size == NULL_TREE)
{
size = size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
#if 0
assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
>= TYPE_PRECISION (TREE_TYPE (size)));
#endif
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
if (ffeinfo_rank (ffebld_info (expr)) == 0
|| TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
num_elements
= is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
else
{
num_elements
= size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
convert (sizetype, size));
num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
num_elements = convert (ffecom_f2c_ftnlen_type_node,
num_elements);
}
num_elements
= ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
num_elements);
variable = convert (string_type_node, variable);
arglist = build_tree_list (NULL_TREE, num_elements);
TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
}
static tree
ffeste_io_dolio_ (ffebld expr)
{
tree type_id;
tree num_elements;
tree variable;
tree size;
tree arglist;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
int tc;
bt = ffeinfo_basictype (ffebld_info (expr));
kt = ffeinfo_kindtype (ffebld_info (expr));
if ((bt == FFEINFO_basictypeANY)
|| (kt == FFEINFO_kindtypeANY))
return error_mark_node;
tc = ffecom_f2c_typecode (bt, kt);
assert (tc != -1);
type_id = build_int_2 (tc, 0);
type_id
= ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
convert (ffecom_f2c_ftnint_type_node,
type_id));
variable = ffecom_arg_ptr_to_expr (expr, &size);
if ((type_id == error_mark_node)
|| (variable == error_mark_node)
|| (size == error_mark_node))
return error_mark_node;
if (size == NULL_TREE)
{
size = size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
#if 0
assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
>= TYPE_PRECISION (TREE_TYPE (size)));
#endif
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
if (ffeinfo_rank (ffebld_info (expr)) == 0
|| TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
num_elements = ffecom_integer_one_node;
else
{
num_elements
= size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
convert (sizetype, size));
num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
num_elements = convert (ffecom_f2c_ftnlen_type_node,
num_elements);
}
num_elements
= ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
num_elements);
variable = convert (string_type_node, variable);
arglist = build_tree_list (NULL_TREE, type_id);
TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements);
TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
= build_tree_list (NULL_TREE, size);
return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
}
static tree
ffeste_io_douio_ (ffebld expr)
{
tree num_elements;
tree variable;
tree size;
tree arglist;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
bool is_complex;
bt = ffeinfo_basictype (ffebld_info (expr));
kt = ffeinfo_kindtype (ffebld_info (expr));
if ((bt == FFEINFO_basictypeANY)
|| (kt == FFEINFO_kindtypeANY))
return error_mark_node;
if (bt == FFEINFO_basictypeCOMPLEX)
{
is_complex = TRUE;
bt = FFEINFO_basictypeREAL;
}
else
is_complex = FALSE;
variable = ffecom_arg_ptr_to_expr (expr, &size);
if ((variable == error_mark_node)
|| (size == error_mark_node))
return error_mark_node;
if (size == NULL_TREE)
{
size = size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
#if 0
assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
>= TYPE_PRECISION (TREE_TYPE (size)));
#endif
size = convert (ffecom_f2c_ftnlen_type_node, size);
}
if (ffeinfo_rank (ffebld_info (expr)) == 0
|| TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
num_elements
= is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
else
{
num_elements
= size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
convert (sizetype, size));
num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
num_elements = convert (ffecom_f2c_ftnlen_type_node,
num_elements);
}
num_elements
= ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
num_elements);
variable = convert (string_type_node, variable);
arglist = build_tree_list (NULL_TREE, num_elements);
TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
}
static GTY(()) tree f2c_alist_struct;
static tree
ffeste_io_ialist_ (bool have_err,
ffestvUnit unit,
ffebld unit_expr,
int unit_dflt)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
bool constantp = TRUE;
static tree errfield, unitfield;
tree errinit, unitinit;
tree unitexp;
static int mynumber = 0;
if (f2c_alist_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
ffecom_f2c_ftnint_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_alist_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
switch (unit)
{
case FFESTV_unitNONE:
case FFESTV_unitASTERISK:
unitinit = build_int_2 (unit_dflt, 0);
unitexp = unitinit;
break;
case FFESTV_unitINTEXPR:
unitexp = ffecom_const_expr (unit_expr);
if (unitexp)
unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
break;
default:
assert ("bad unit spec" == NULL);
unitinit = ffecom_integer_zero_node;
unitexp = unitinit;
break;
}
inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_alist_%d",
mynumber++),
f2c_alist_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
if (! unitexp)
ffecom_prepare_expr (unit_expr);
ffecom_prepare_end ();
if (! unitexp)
{
unitexp = ffecom_expr (unit_expr);
ffeste_f2c_compile_ (unitfield, unitexp);
}
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static GTY(()) tree f2c_cilist_struct;
static tree
ffeste_io_cilist_ (bool have_err,
ffestvUnit unit,
ffebld unit_expr,
int unit_dflt,
bool have_end,
ffestvFormat format,
ffestpFile *format_spec,
bool rec,
ffebld rec_expr)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
bool constantp = TRUE;
static tree errfield, unitfield, endfield, formatfield, recfield;
tree errinit, unitinit, endinit, formatinit, recinit;
tree unitexp, formatexp, recexp;
static int mynumber = 0;
if (f2c_cilist_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
ffecom_f2c_ftnint_type_node);
endfield = ffecom_decl_field (ref, unitfield, "end",
ffecom_f2c_flag_type_node);
formatfield = ffecom_decl_field (ref, endfield, "format",
string_type_node);
recfield = ffecom_decl_field (ref, formatfield, "rec",
ffecom_f2c_ftnint_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_cilist_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
switch (unit)
{
case FFESTV_unitNONE:
case FFESTV_unitASTERISK:
unitinit = build_int_2 (unit_dflt, 0);
unitexp = unitinit;
break;
case FFESTV_unitINTEXPR:
unitexp = ffecom_const_expr (unit_expr);
if (unitexp)
unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
break;
default:
assert ("bad unit spec" == NULL);
unitinit = ffecom_integer_zero_node;
unitexp = unitinit;
break;
}
switch (format)
{
case FFESTV_formatNONE:
formatinit = null_pointer_node;
formatexp = formatinit;
break;
case FFESTV_formatLABEL:
formatexp = error_mark_node;
formatinit = ffecom_lookup_label (format_spec->u.label);
if ((formatinit == NULL_TREE)
|| (TREE_CODE (formatinit) == ERROR_MARK))
break;
formatinit = ffecom_1 (ADDR_EXPR,
build_pointer_type (void_type_node),
formatinit);
TREE_CONSTANT (formatinit) = 1;
break;
case FFESTV_formatCHAREXPR:
formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
if (formatexp)
formatinit = formatexp;
else
{
formatinit = null_pointer_node;
constantp = FALSE;
}
break;
case FFESTV_formatASTERISK:
formatinit = null_pointer_node;
formatexp = formatinit;
break;
case FFESTV_formatINTEXPR:
formatinit = null_pointer_node;
formatexp = ffecom_expr_assign (format_spec->u.expr);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
error ("ASSIGNed FORMAT specifier is too small");
formatexp = convert (string_type_node, formatexp);
break;
case FFESTV_formatNAMELIST:
formatinit = ffecom_expr (format_spec->u.expr);
formatexp = formatinit;
break;
default:
assert ("bad format spec" == NULL);
formatinit = integer_zero_node;
formatexp = formatinit;
break;
}
ffeste_f2c_init_flag_ (have_end, endinit);
if (rec)
recexp = ffecom_const_expr (rec_expr);
else
recexp = ffecom_integer_zero_node;
if (recexp)
recinit = recexp;
else
{
recinit = ffecom_integer_zero_node;
constantp = FALSE;
}
inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
ffeste_f2c_init_next_ (endinit);
ffeste_f2c_init_next_ (formatinit);
ffeste_f2c_init_next_ (recinit);
inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_cilist_%d",
mynumber++),
f2c_cilist_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
if (! unitexp)
ffecom_prepare_expr (unit_expr);
if (! formatexp)
ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
if (! recexp)
ffecom_prepare_expr (rec_expr);
ffecom_prepare_end ();
if (! unitexp)
{
unitexp = ffecom_expr (unit_expr);
ffeste_f2c_compile_ (unitfield, unitexp);
}
if (! formatexp)
{
formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
ffeste_f2c_compile_ (formatfield, formatexp);
}
else if (format == FFESTV_formatINTEXPR)
ffeste_f2c_compile_ (formatfield, formatexp);
if (! recexp)
{
recexp = ffecom_expr (rec_expr);
ffeste_f2c_compile_ (recfield, recexp);
}
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static GTY(()) tree f2c_close_struct;
static tree
ffeste_io_cllist_ (bool have_err,
ffebld unit_expr,
ffestpFile *stat_spec)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
tree ignore;
bool constantp = TRUE;
static tree errfield, unitfield, statfield;
tree errinit, unitinit, statinit;
tree unitexp, statexp;
static int mynumber = 0;
if (f2c_close_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
ffecom_f2c_ftnint_type_node);
statfield = ffecom_decl_field (ref, unitfield, "stat",
string_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_close_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
unitexp = ffecom_const_expr (unit_expr);
if (unitexp)
unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
ffeste_f2c_init_next_ (statinit);
inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_cllist_%d",
mynumber++),
f2c_close_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
if (! unitexp)
ffecom_prepare_expr (unit_expr);
if (! statexp)
ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
ffecom_prepare_end ();
if (! unitexp)
{
unitexp = ffecom_expr (unit_expr);
ffeste_f2c_compile_ (unitfield, unitexp);
}
ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static GTY(()) tree f2c_icilist_struct;
static tree
ffeste_io_icilist_ (bool have_err,
ffebld unit_expr,
bool have_end,
ffestvFormat format,
ffestpFile *format_spec)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
bool constantp = TRUE;
static tree errfield, unitfield, endfield, formatfield, unitlenfield,
unitnumfield;
tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
tree unitexp, formatexp, unitlenexp, unitnumexp;
static int mynumber = 0;
if (f2c_icilist_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
string_type_node);
endfield = ffecom_decl_field (ref, unitfield, "end",
ffecom_f2c_flag_type_node);
formatfield = ffecom_decl_field (ref, endfield, "format",
string_type_node);
unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
ffecom_f2c_ftnint_type_node);
unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
ffecom_f2c_ftnint_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_icilist_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
if (unitexp)
unitinit = unitexp;
else
{
unitinit = null_pointer_node;
constantp = FALSE;
}
if (unitlenexp)
unitleninit = unitlenexp;
else
{
unitleninit = ffecom_integer_zero_node;
constantp = FALSE;
}
if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
|| (unitexp
&& TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
{
unitnuminit = ffecom_integer_one_node;
unitnumexp = unitnuminit;
}
else if (unitexp && unitlenexp)
{
unitnuminit
= size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
convert (sizetype, unitlenexp));
unitnuminit = size_binop (CEIL_DIV_EXPR, unitnuminit,
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
unitnumexp = unitnuminit;
}
else
{
unitnuminit = ffecom_integer_zero_node;
unitnumexp = NULL_TREE;
constantp = FALSE;
}
switch (format)
{
case FFESTV_formatNONE:
formatinit = null_pointer_node;
formatexp = formatinit;
break;
case FFESTV_formatLABEL:
formatexp = error_mark_node;
formatinit = ffecom_lookup_label (format_spec->u.label);
if ((formatinit == NULL_TREE)
|| (TREE_CODE (formatinit) == ERROR_MARK))
break;
formatinit = ffecom_1 (ADDR_EXPR,
build_pointer_type (void_type_node),
formatinit);
TREE_CONSTANT (formatinit) = 1;
break;
case FFESTV_formatCHAREXPR:
ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
break;
case FFESTV_formatASTERISK:
formatinit = null_pointer_node;
formatexp = formatinit;
break;
case FFESTV_formatINTEXPR:
formatinit = null_pointer_node;
formatexp = ffecom_expr_assign (format_spec->u.expr);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
error ("ASSIGNed FORMAT specifier is too small");
formatexp = convert (string_type_node, formatexp);
break;
default:
assert ("bad format spec" == NULL);
formatinit = ffecom_integer_zero_node;
formatexp = formatinit;
break;
}
ffeste_f2c_init_flag_ (have_end, endinit);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
ffeste_f2c_init_next_ (endinit);
ffeste_f2c_init_next_ (formatinit);
ffeste_f2c_init_next_ (unitleninit);
ffeste_f2c_init_next_ (unitnuminit);
inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_icilist_%d",
mynumber++),
f2c_icilist_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
if (! unitexp)
ffecom_prepare_arg_ptr_to_expr (unit_expr);
ffeste_f2c_prepare_format_ (format_spec, formatexp);
ffecom_prepare_end ();
if (! unitexp || ! unitlenexp)
{
int need_unitexp = (! unitexp);
int need_unitlenexp = (! unitlenexp);
unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
if (need_unitexp)
ffeste_f2c_compile_ (unitfield, unitexp);
if (need_unitlenexp)
ffeste_f2c_compile_ (unitlenfield, unitlenexp);
}
if (! unitnumexp
&& unitexp != error_mark_node
&& unitlenexp != error_mark_node)
{
unitnumexp
= size_binop (CEIL_DIV_EXPR,
TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
convert (sizetype, unitlenexp));
unitnumexp = size_binop (CEIL_DIV_EXPR, unitnumexp,
size_int (TYPE_PRECISION (char_type_node)
/ BITS_PER_UNIT));
ffeste_f2c_compile_ (unitnumfield, unitnumexp);
}
if (format == FFESTV_formatINTEXPR)
ffeste_f2c_compile_ (formatfield, formatexp);
else
ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static GTY(()) tree f2c_inquire_struct;
static tree
ffeste_io_inlist_ (bool have_err,
ffestpFile *unit_spec,
ffestpFile *file_spec,
ffestpFile *exist_spec,
ffestpFile *open_spec,
ffestpFile *number_spec,
ffestpFile *named_spec,
ffestpFile *name_spec,
ffestpFile *access_spec,
ffestpFile *sequential_spec,
ffestpFile *direct_spec,
ffestpFile *form_spec,
ffestpFile *formatted_spec,
ffestpFile *unformatted_spec,
ffestpFile *recl_spec,
ffestpFile *nextrec_spec,
ffestpFile *blank_spec)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
bool constantp = TRUE;
static tree errfield, unitfield, filefield, filelenfield, existfield,
openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
sequentialleninit, directinit, directleninit, forminit, formleninit,
formattedinit, formattedleninit, unformattedinit, unformattedleninit,
reclinit, nextrecinit, blankinit, blankleninit;
tree
unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
static int mynumber = 0;
if (f2c_inquire_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
ffecom_f2c_ftnint_type_node);
filefield = ffecom_decl_field (ref, unitfield, "file",
string_type_node);
filelenfield = ffecom_decl_field (ref, filefield, "filelen",
ffecom_f2c_ftnlen_type_node);
existfield = ffecom_decl_field (ref, filelenfield, "exist",
ffecom_f2c_ptr_to_ftnint_type_node);
openfield = ffecom_decl_field (ref, existfield, "open",
ffecom_f2c_ptr_to_ftnint_type_node);
numberfield = ffecom_decl_field (ref, openfield, "number",
ffecom_f2c_ptr_to_ftnint_type_node);
namedfield = ffecom_decl_field (ref, numberfield, "named",
ffecom_f2c_ptr_to_ftnint_type_node);
namefield = ffecom_decl_field (ref, namedfield, "name",
string_type_node);
namelenfield = ffecom_decl_field (ref, namefield, "namelen",
ffecom_f2c_ftnlen_type_node);
accessfield = ffecom_decl_field (ref, namelenfield, "access",
string_type_node);
accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
ffecom_f2c_ftnlen_type_node);
sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
string_type_node);
sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
"sequentiallen",
ffecom_f2c_ftnlen_type_node);
directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
string_type_node);
directlenfield = ffecom_decl_field (ref, directfield, "directlen",
ffecom_f2c_ftnlen_type_node);
formfield = ffecom_decl_field (ref, directlenfield, "form",
string_type_node);
formlenfield = ffecom_decl_field (ref, formfield, "formlen",
ffecom_f2c_ftnlen_type_node);
formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
string_type_node);
formattedlenfield = ffecom_decl_field (ref, formattedfield,
"formattedlen",
ffecom_f2c_ftnlen_type_node);
unformattedfield = ffecom_decl_field (ref, formattedlenfield,
"unformatted",
string_type_node);
unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
"unformattedlen",
ffecom_f2c_ftnlen_type_node);
reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
ffecom_f2c_ptr_to_ftnint_type_node);
nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
ffecom_f2c_ptr_to_ftnint_type_node);
blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
string_type_node);
blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
ffecom_f2c_ftnlen_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_inquire_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
file_spec);
ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
name_spec);
ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
accessleninit, access_spec);
ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
sequentialleninit, sequential_spec);
ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
directleninit, direct_spec);
ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
form_spec);
ffeste_f2c_init_char_ (formattedexp, formattedinit,
formattedlenexp, formattedleninit, formatted_spec);
ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
unformattedleninit, unformatted_spec);
ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
blankleninit, blank_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
ffeste_f2c_init_next_ (fileinit);
ffeste_f2c_init_next_ (fileleninit);
ffeste_f2c_init_next_ (existinit);
ffeste_f2c_init_next_ (openinit);
ffeste_f2c_init_next_ (numberinit);
ffeste_f2c_init_next_ (namedinit);
ffeste_f2c_init_next_ (nameinit);
ffeste_f2c_init_next_ (nameleninit);
ffeste_f2c_init_next_ (accessinit);
ffeste_f2c_init_next_ (accessleninit);
ffeste_f2c_init_next_ (sequentialinit);
ffeste_f2c_init_next_ (sequentialleninit);
ffeste_f2c_init_next_ (directinit);
ffeste_f2c_init_next_ (directleninit);
ffeste_f2c_init_next_ (forminit);
ffeste_f2c_init_next_ (formleninit);
ffeste_f2c_init_next_ (formattedinit);
ffeste_f2c_init_next_ (formattedleninit);
ffeste_f2c_init_next_ (unformattedinit);
ffeste_f2c_init_next_ (unformattedleninit);
ffeste_f2c_init_next_ (reclinit);
ffeste_f2c_init_next_ (nextrecinit);
ffeste_f2c_init_next_ (blankinit);
ffeste_f2c_init_next_ (blankleninit);
inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_inlist_%d",
mynumber++),
f2c_inquire_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
ffeste_f2c_prepare_int_ (unit_spec, unitexp);
ffeste_f2c_prepare_char_ (file_spec, fileexp);
ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
ffeste_f2c_prepare_char_ (name_spec, nameexp);
ffeste_f2c_prepare_char_ (access_spec, accessexp);
ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
ffeste_f2c_prepare_char_ (direct_spec, directexp);
ffeste_f2c_prepare_char_ (form_spec, formexp);
ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
ffeste_f2c_prepare_char_ (blank_spec, blankexp);
ffecom_prepare_end ();
ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
fileexp, filelenexp);
ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
namelenexp);
ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
accessexp, accesslenexp);
ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
sequential_spec, sequentialexp,
sequentiallenexp);
ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
directexp, directlenexp);
ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
formlenexp);
ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
formattedexp, formattedlenexp);
ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
unformatted_spec, unformattedexp,
unformattedlenexp);
ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
blanklenexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static GTY(()) tree f2c_open_struct;
static tree
ffeste_io_olist_ (bool have_err,
ffebld unit_expr,
ffestpFile *file_spec,
ffestpFile *stat_spec,
ffestpFile *access_spec,
ffestpFile *form_spec,
ffestpFile *recl_spec,
ffestpFile *blank_spec)
{
tree t;
tree ttype;
tree field;
tree inits, initn;
tree ignore;
bool constantp = TRUE;
static tree errfield, unitfield, filefield, filelenfield, statfield,
accessfield, formfield, reclfield, blankfield;
tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
forminit, reclinit, blankinit;
tree
unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
blankexp;
static int mynumber = 0;
if (f2c_open_struct == NULL_TREE)
{
tree ref;
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
ffecom_f2c_flag_type_node);
unitfield = ffecom_decl_field (ref, errfield, "unit",
ffecom_f2c_ftnint_type_node);
filefield = ffecom_decl_field (ref, unitfield, "file",
string_type_node);
filelenfield = ffecom_decl_field (ref, filefield, "filelen",
ffecom_f2c_ftnlen_type_node);
statfield = ffecom_decl_field (ref, filelenfield, "stat",
string_type_node);
accessfield = ffecom_decl_field (ref, statfield, "access",
string_type_node);
formfield = ffecom_decl_field (ref, accessfield, "form",
string_type_node);
reclfield = ffecom_decl_field (ref, formfield, "recl",
ffecom_f2c_ftnint_type_node);
blankfield = ffecom_decl_field (ref, reclfield, "blank",
string_type_node);
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
f2c_open_struct = ref;
}
ffeste_f2c_init_flag_ (have_err, errinit);
unitexp = ffecom_const_expr (unit_expr);
if (unitexp)
unitinit = unitexp;
else
{
unitinit = ffecom_integer_zero_node;
constantp = FALSE;
}
ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
file_spec);
ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
initn = inits;
ffeste_f2c_init_next_ (unitinit);
ffeste_f2c_init_next_ (fileinit);
ffeste_f2c_init_next_ (fileleninit);
ffeste_f2c_init_next_ (statinit);
ffeste_f2c_init_next_ (accessinit);
ffeste_f2c_init_next_ (forminit);
ffeste_f2c_init_next_ (reclinit);
ffeste_f2c_init_next_ (blankinit);
inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
TREE_CONSTANT (inits) = constantp ? 1 : 0;
TREE_STATIC (inits) = 1;
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_olist_%d",
mynumber++),
f2c_open_struct);
TREE_STATIC (t) = 1;
t = ffecom_start_decl (t, 1);
ffecom_finish_decl (t, inits, 0);
if (! unitexp)
ffecom_prepare_expr (unit_expr);
ffeste_f2c_prepare_char_ (file_spec, fileexp);
ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
ffeste_f2c_prepare_int_ (recl_spec, reclexp);
ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
ffecom_prepare_end ();
if (! unitexp)
{
unitexp = ffecom_expr (unit_expr);
ffeste_f2c_compile_ (unitfield, unitexp);
}
ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
filelenexp);
ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
ttype = build_pointer_type (TREE_TYPE (t));
t = ffecom_1 (ADDR_EXPR, ttype, t);
t = build_tree_list (NULL_TREE, t);
return t;
}
static void
ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
{
tree alist;
bool iostat;
bool errl;
ffeste_emit_line_note_ ();
#define specified(something) (info->beru_spec[something].kw_or_val_present)
iostat = specified (FFESTP_beruixIOSTAT);
errl = specified (FFESTP_beruixERR);
#undef specified
ffeste_start_stmt_ ();
if (errl)
{
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->beru_spec[FFESTP_beruixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("beru", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
assert (ffeste_io_err_ == NULL_TREE);
}
ffeste_end_stmt_ ();
}
void
ffeste_do (ffestw block)
{
ffeste_emit_line_note_ ();
if (ffestw_do_tvar (block) == 0)
{
expand_end_loop ();
ffeste_end_block_ (block);
}
else
ffeste_end_iterdo_ (block,
ffestw_do_tvar (block),
ffestw_do_incr_saved (block),
ffestw_do_count_var (block));
}
void
ffeste_end_R807 ()
{
ffeste_emit_line_note_ ();
expand_end_cond ();
ffeste_end_block_ (NULL);
}
void
ffeste_labeldef_branch (ffelab label)
{
tree glabel;
glabel = ffecom_lookup_label (label);
assert (glabel != NULL_TREE);
if (TREE_CODE (glabel) == ERROR_MARK)
return;
assert (DECL_INITIAL (glabel) == NULL_TREE);
DECL_INITIAL (glabel) = error_mark_node;
DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
emit_nop ();
expand_label (glabel);
}
void
ffeste_labeldef_format (ffelab label)
{
ffeste_label_formatdef_ = label;
}
void
ffeste_R737A (ffebld dest, ffebld source)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_stmt_ ();
ffecom_expand_let_stmt (dest, source);
ffeste_end_stmt_ ();
}
void
ffeste_R803 (ffestw block, ffebld expr)
{
tree temp;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_block_ (block);
temp = ffecom_make_tempvar ("ifthen", integer_type_node,
FFETARGET_charactersizeNONE, -1);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
if (ffecom_prepare_end ())
{
tree result;
result = ffecom_modify (void_type_node,
temp,
ffecom_truth_value (ffecom_expr (expr)));
expand_expr_stmt (result);
ffeste_end_stmt_ ();
}
else
{
ffeste_end_stmt_ ();
temp = ffecom_truth_value (ffecom_expr (expr));
}
expand_start_cond (temp, 0);
ffestw_set_ifthen_fake_else (block, 0);
}
void
ffeste_R804 (ffestw block, ffebld expr)
{
tree temp;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_start_else ();
ffeste_start_block_ (block);
temp = ffecom_make_tempvar ("elseif", integer_type_node,
FFETARGET_charactersizeNONE, -1);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
if (ffecom_prepare_end ())
{
tree result;
result = ffecom_modify (void_type_node,
temp,
ffecom_truth_value (ffecom_expr (expr)));
expand_expr_stmt (result);
ffeste_end_stmt_ ();
}
else
{
ffeste_end_stmt_ ();
temp = ffecom_truth_value (ffecom_expr (expr));
}
expand_start_cond (temp, 0);
ffestw_set_ifthen_fake_else (block,
ffestw_ifthen_fake_else (block) + 1);
}
void
ffeste_R805 (ffestw block UNUSED)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_start_else ();
}
void
ffeste_R806 (ffestw block)
{
int i = ffestw_ifthen_fake_else (block) + 1;
ffeste_emit_line_note_ ();
for (; i; --i)
{
expand_end_cond ();
ffeste_end_block_ (block);
}
}
void
ffeste_R807 (ffebld expr)
{
tree temp;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_block_ (NULL);
temp = ffecom_make_tempvar ("if", integer_type_node,
FFETARGET_charactersizeNONE, -1);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
if (ffecom_prepare_end ())
{
tree result;
result = ffecom_modify (void_type_node,
temp,
ffecom_truth_value (ffecom_expr (expr)));
expand_expr_stmt (result);
ffeste_end_stmt_ ();
}
else
{
ffeste_end_stmt_ ();
temp = ffecom_truth_value (ffecom_expr (expr));
}
expand_start_cond (temp, 0);
}
void
ffeste_R809 (ffestw block, ffebld expr)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_block_ (block);
if ((expr == NULL)
|| (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeANY))
ffestw_set_select_texpr (block, error_mark_node);
else if (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeCHARACTER)
{
ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
FFEBAD_severityFATAL);
ffebad_here (0, ffestw_line (block), ffestw_col (block));
ffebad_finish ();
ffestw_set_select_texpr (block, error_mark_node);
}
else
{
tree result;
tree texpr;
result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
ffeinfo_size (ffebld_info (expr)),
-1);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
ffecom_prepare_end ();
texpr = ffecom_expr (expr);
assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
== TYPE_MAIN_VARIANT (TREE_TYPE (result)));
texpr = ffecom_modify (void_type_node,
result,
texpr);
expand_expr_stmt (texpr);
ffeste_end_stmt_ ();
expand_start_case (1, result, TREE_TYPE (result),
"SELECT CASE statement");
ffestw_set_select_texpr (block, texpr);
ffestw_set_select_break (block, FALSE);
}
}
void
ffeste_R810 (ffestw block, unsigned long casenum)
{
ffestwSelect s = ffestw_select (block);
ffestwCase c;
tree texprlow;
tree texprhigh;
tree tlabel;
int pushok;
tree duplicate;
ffeste_check_simple_ ();
if (s->first_stmt == (ffestwCase) &s->first_rel)
c = NULL;
else
c = s->first_stmt;
ffeste_emit_line_note_ ();
if (ffestw_select_texpr (block) == error_mark_node)
return;
tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
if (ffestw_select_break (block))
expand_exit_something ();
else
ffestw_set_select_break (block, TRUE);
if ((c == NULL) || (casenum != c->casenum))
{
if (casenum == 0)
{
pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
assert (pushok == 0);
}
}
else
do
{
texprlow = (c->low == NULL) ? NULL_TREE
: ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
s->kindtype,
ffecom_tree_type[s->type][s->kindtype]);
if (c->low != c->high)
{
texprhigh = (c->high == NULL) ? NULL_TREE
: ffecom_constantunion (&ffebld_constant_union (c->high),
s->type, s->kindtype,
ffecom_tree_type[s->type][s->kindtype]);
pushok = pushcase_range (texprlow, texprhigh, convert,
tlabel, &duplicate);
}
else
pushok = pushcase (texprlow, convert, tlabel, &duplicate);
assert((pushok !=2) || (pushok !=0));
if (pushok==2)
{
ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",
FFEBAD_severityFATAL);
ffebad_here (0, ffestw_line (block), ffestw_col (block));
ffebad_finish ();
ffestw_set_select_texpr (block, error_mark_node);
}
c = c->next_stmt;
c->previous_stmt->previous_stmt->next_stmt = c;
c->previous_stmt = c->previous_stmt->previous_stmt;
}
while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
}
void
ffeste_R811 (ffestw block)
{
ffeste_emit_line_note_ ();
if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
expand_end_case (ffestw_select_texpr (block));
ffeste_end_block_ (block);
}
void
ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
ffebld start, ffelexToken start_token,
ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
var,
start, start_token,
end, end_token,
incr, incr_token,
"Iterative DO loop");
}
void
ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
{
tree result;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_block_ (block);
if (expr)
{
struct nesting *loop;
tree mod;
result = ffecom_make_tempvar ("dowhile", integer_type_node,
FFETARGET_charactersizeNONE, -1);
loop = expand_start_loop (1);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
ffecom_prepare_end ();
mod = ffecom_modify (void_type_node,
result,
ffecom_truth_value (ffecom_expr (expr)));
expand_expr_stmt (mod);
ffeste_end_stmt_ ();
ffestw_set_do_hook (block, loop);
expand_exit_loop_top_cond (0, result);
}
else
ffestw_set_do_hook (block, expand_start_loop (1));
ffestw_set_do_tvar (block, NULL_TREE);
}
void
ffeste_R825 ()
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
emit_nop ();
}
void
ffeste_R834 (ffestw block)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_continue_loop (ffestw_do_hook (block));
}
void
ffeste_R835 (ffestw block)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_exit_loop (ffestw_do_hook (block));
}
void
ffeste_R836 (ffelab label)
{
tree glabel;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
glabel = ffecom_lookup_label (label);
if ((glabel != NULL_TREE)
&& (TREE_CODE (glabel) != ERROR_MARK))
{
expand_goto (glabel);
TREE_USED (glabel) = 1;
}
}
void
ffeste_R837 (ffelab *labels, int count, ffebld expr)
{
int i;
tree texpr;
tree value;
tree tlabel;
int pushok;
tree duplicate;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
ffecom_prepare_end ();
texpr = ffecom_expr (expr);
expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
for (i = 0; i < count; ++i)
{
value = build_int_2 (i + 1, 0);
tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
pushok = pushcase (value, convert, tlabel, &duplicate);
assert (pushok == 0);
tlabel = ffecom_lookup_label (labels[i]);
if ((tlabel == NULL_TREE)
|| (TREE_CODE (tlabel) == ERROR_MARK))
continue;
expand_goto (tlabel);
TREE_USED (tlabel) = 1;
}
expand_end_case (texpr);
ffeste_end_stmt_ ();
}
void
ffeste_R838 (ffelab label, ffebld target)
{
tree expr_tree;
tree label_tree;
tree target_tree;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
label_tree = ffecom_lookup_label (label);
if ((label_tree != NULL_TREE)
&& (TREE_CODE (label_tree) != ERROR_MARK))
{
label_tree = ffecom_1 (ADDR_EXPR,
build_pointer_type (void_type_node),
label_tree);
TREE_CONSTANT (label_tree) = 1;
target_tree = ffecom_expr_assign_w (target);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
error ("ASSIGN to variable that is too small");
label_tree = convert (TREE_TYPE (target_tree), label_tree);
expr_tree = ffecom_modify (void_type_node,
target_tree,
label_tree);
expand_expr_stmt (expr_tree);
}
}
void
ffeste_R839 (ffebld target)
{
tree t;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
t = ffecom_expr_assign (target);
if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
< GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
error ("ASSIGNed GOTO target variable is too small");
expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
}
void
ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
{
tree gneg = ffecom_lookup_label (neg);
tree gzero = ffecom_lookup_label (zero);
tree gpos = ffecom_lookup_label (pos);
tree texpr;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
return;
if ((TREE_CODE (gneg) == ERROR_MARK)
|| (TREE_CODE (gzero) == ERROR_MARK)
|| (TREE_CODE (gpos) == ERROR_MARK))
return;
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
ffecom_prepare_end ();
if (neg == zero)
{
if (neg == pos)
expand_goto (gzero);
else
{
texpr = ffecom_expr (expr);
texpr = ffecom_2 (LE_EXPR, integer_type_node,
texpr,
convert (TREE_TYPE (texpr),
integer_zero_node));
expand_start_cond (ffecom_truth_value (texpr), 0);
expand_goto (gzero);
expand_start_else ();
expand_goto (gpos);
expand_end_cond ();
}
}
else if (neg == pos)
{
texpr = ffecom_expr (expr);
texpr = ffecom_2 (NE_EXPR, integer_type_node,
texpr,
convert (TREE_TYPE (texpr),
integer_zero_node));
expand_start_cond (ffecom_truth_value (texpr), 0);
expand_goto (gneg);
expand_start_else ();
expand_goto (gzero);
expand_end_cond ();
}
else if (zero == pos)
{
texpr = ffecom_expr (expr);
texpr = ffecom_2 (GE_EXPR, integer_type_node,
texpr,
convert (TREE_TYPE (texpr),
integer_zero_node));
expand_start_cond (ffecom_truth_value (texpr), 0);
expand_goto (gzero);
expand_start_else ();
expand_goto (gneg);
expand_end_cond ();
}
else
{
tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
texpr = ffecom_2 (LT_EXPR, integer_type_node,
expr_saved,
convert (TREE_TYPE (expr_saved),
integer_zero_node));
expand_start_cond (ffecom_truth_value (texpr), 0);
expand_goto (gneg);
texpr = ffecom_2 (GT_EXPR, integer_type_node,
expr_saved,
convert (TREE_TYPE (expr_saved),
integer_zero_node));
expand_start_elseif (ffecom_truth_value (texpr));
expand_goto (gpos);
expand_start_else ();
expand_goto (gzero);
expand_end_cond ();
}
ffeste_end_stmt_ ();
}
void
ffeste_R841 ()
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
emit_nop ();
}
void
ffeste_R842 (ffebld expr)
{
tree callit;
ffelexToken msg;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
if ((expr == NULL)
|| (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeANY))
{
msg = ffelex_token_new_character ("",
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
expr = ffebld_new_conter (ffebld_constant_new_characterdefault
(msg));
ffelex_token_kill (msg);
ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTERDEFAULT,
0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, 0));
}
else if (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeINTEGER)
{
char num[50];
assert (ffebld_op (expr) == FFEBLD_opCONTER);
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeINTEGERDEFAULT);
sprintf (num, "%" ffetargetIntegerDefault_f "d",
ffebld_constant_integer1 (ffebld_conter (expr)));
msg = ffelex_token_new_character (num,
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
ffelex_token_kill (msg);
ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTERDEFAULT,
0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, 0));
}
else
{
assert (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeCHARACTER);
assert (ffebld_op (expr) == FFEBLD_opCONTER);
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeCHARACTERDEFAULT);
}
callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
NULL_TREE);
TREE_SIDE_EFFECTS (callit) = 1;
expand_expr_stmt (callit);
}
void
ffeste_R843 (ffebld expr)
{
tree callit;
ffelexToken msg;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
if ((expr == NULL)
|| (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeANY))
{
msg = ffelex_token_new_character ("",
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
ffelex_token_kill (msg);
ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTERDEFAULT,
0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, 0));
}
else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
{
char num[50];
assert (ffebld_op (expr) == FFEBLD_opCONTER);
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeINTEGERDEFAULT);
sprintf (num, "%" ffetargetIntegerDefault_f "d",
ffebld_constant_integer1 (ffebld_conter (expr)));
msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
ffelex_token_kill (msg);
ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTERDEFAULT,
0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, 0));
}
else
{
assert (ffeinfo_basictype (ffebld_info (expr))
== FFEINFO_basictypeCHARACTER);
assert (ffebld_op (expr) == FFEBLD_opCONTER);
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeCHARACTERDEFAULT);
}
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
NULL_TREE);
TREE_SIDE_EFFECTS (callit) = 1;
expand_expr_stmt (callit);
}
void
ffeste_R904 (ffestpOpenStmt *info)
{
tree args;
bool iostat;
bool errl;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
#define specified(something) (info->open_spec[something].kw_or_val_present)
iostat = specified (FFESTP_openixIOSTAT);
errl = specified (FFESTP_openixERR);
#undef specified
ffeste_start_stmt_ ();
if (errl)
{
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->open_spec[FFESTP_openixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->open_spec[FFESTP_openixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("open", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
args = ffeste_io_olist_ (errl || iostat,
info->open_spec[FFESTP_openixUNIT].u.expr,
&info->open_spec[FFESTP_openixFILE],
&info->open_spec[FFESTP_openixSTATUS],
&info->open_spec[FFESTP_openixACCESS],
&info->open_spec[FFESTP_openixFORM],
&info->open_spec[FFESTP_openixRECL],
&info->open_spec[FFESTP_openixBLANK]);
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
assert (ffeste_io_err_ == NULL_TREE);
}
ffeste_end_stmt_ ();
}
void
ffeste_R907 (ffestpCloseStmt *info)
{
tree args;
bool iostat;
bool errl;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
#define specified(something) (info->close_spec[something].kw_or_val_present)
iostat = specified (FFESTP_closeixIOSTAT);
errl = specified (FFESTP_closeixERR);
#undef specified
ffeste_start_stmt_ ();
if (errl)
{
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->close_spec[FFESTP_closeixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->close_spec[FFESTP_closeixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("close", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
args = ffeste_io_cllist_ (errl || iostat,
info->close_spec[FFESTP_closeixUNIT].u.expr,
&info->close_spec[FFESTP_closeixSTATUS]);
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
assert (ffeste_io_err_ == NULL_TREE);
}
ffeste_end_stmt_ ();
}
void
ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
ffestvUnit unit, ffestvFormat format, bool rec,
bool key UNUSED)
{
ffecomGfrt start;
ffecomGfrt end;
tree cilist;
bool iostat;
bool errl;
bool endl;
ffeste_check_start_ ();
ffeste_emit_line_note_ ();
switch (format)
{
case FFESTV_formatNONE:
ffeste_io_driver_ = ffeste_io_douio_;
if (rec)
start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
else
start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
break;
case FFESTV_formatLABEL:
case FFESTV_formatCHAREXPR:
case FFESTV_formatINTEXPR:
ffeste_io_driver_ = ffeste_io_dofio_;
if (rec)
start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
else if (unit == FFESTV_unitCHAREXPR)
start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
else
start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
break;
case FFESTV_formatASTERISK:
ffeste_io_driver_ = ffeste_io_dolio_;
if (unit == FFESTV_unitCHAREXPR)
start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
else
start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
break;
case FFESTV_formatNAMELIST:
ffeste_io_driver_ = NULL;
start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
break;
default:
assert ("Weird stuff" == NULL);
start = FFECOM_gfrt, end = FFECOM_gfrt;
break;
}
ffeste_io_endgfrt_ = end;
#define specified(something) (info->read_spec[something].kw_or_val_present)
iostat = specified (FFESTP_readixIOSTAT);
errl = specified (FFESTP_readixERR);
endl = specified (FFESTP_readixEND);
#undef specified
ffeste_start_stmt_ ();
if (errl)
{
ffeste_io_err_
= ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
if (endl)
{
ffeste_io_end_
= ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
ffeste_io_abort_is_temp_ = TRUE;
ffeste_io_abort_ = ffecom_temp_label ();
}
else
{
ffeste_io_end_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = ffeste_io_err_;
}
}
else
{
ffeste_io_err_ = NULL_TREE;
if (endl)
{
ffeste_io_end_
= ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = ffeste_io_end_;
}
else
{
ffeste_io_end_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_
= ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("read", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
if (unit == FFESTV_unitCHAREXPR)
cilist = ffeste_io_icilist_ (errl || iostat,
info->read_spec[FFESTP_readixUNIT].u.expr,
endl || iostat, format,
&info->read_spec[FFESTP_readixFORMAT]);
else
cilist = ffeste_io_cilist_ (errl || iostat, unit,
info->read_spec[FFESTP_readixUNIT].u.expr,
5, endl || iostat, format,
&info->read_spec[FFESTP_readixFORMAT],
rec,
info->read_spec[FFESTP_readixREC].u.expr);
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
void
ffeste_R909_item (ffebld expr, ffelexToken expr_token)
{
ffeste_check_item_ ();
if (expr == NULL)
return;
while (ffebld_op (expr) == FFEBLD_opPAREN)
expr = ffebld_left (expr);
if (ffebld_op (expr) == FFEBLD_opANY)
return;
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
{
ffeste_start_stmt_ ();
ffecom_prepare_arg_ptr_to_expr (expr);
ffecom_prepare_end ();
ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
ffeste_end_stmt_ ();
}
}
void
ffeste_R909_finish ()
{
ffeste_check_finish_ ();
if (ffeste_io_endgfrt_ != FFECOM_gfrt)
ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
if ((ffeste_io_end_ != NULL_TREE)
&& (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
{
expand_start_cond (ffecom_truth_value
(ffecom_2 (LT_EXPR, integer_type_node,
ffeste_io_iostat_,
ffecom_integer_zero_node)),
0);
expand_goto (ffeste_io_end_);
expand_end_cond ();
}
if ((ffeste_io_err_ != NULL_TREE)
&& (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
{
expand_start_cond (ffecom_truth_value
(ffecom_2 (GT_EXPR, integer_type_node,
ffeste_io_iostat_,
ffecom_integer_zero_node)),
0);
expand_goto (ffeste_io_err_);
expand_end_cond ();
}
}
ffeste_end_stmt_ ();
}
void
ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
ffestvFormat format, bool rec)
{
ffecomGfrt start;
ffecomGfrt end;
tree cilist;
bool iostat;
bool errl;
ffeste_check_start_ ();
ffeste_emit_line_note_ ();
switch (format)
{
case FFESTV_formatNONE:
ffeste_io_driver_ = ffeste_io_douio_;
if (rec)
start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
else
start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
break;
case FFESTV_formatLABEL:
case FFESTV_formatCHAREXPR:
case FFESTV_formatINTEXPR:
ffeste_io_driver_ = ffeste_io_dofio_;
if (rec)
start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
else if (unit == FFESTV_unitCHAREXPR)
start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
else
start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
break;
case FFESTV_formatASTERISK:
ffeste_io_driver_ = ffeste_io_dolio_;
if (unit == FFESTV_unitCHAREXPR)
start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
else
start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
break;
case FFESTV_formatNAMELIST:
ffeste_io_driver_ = NULL;
start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
break;
default:
assert ("Weird stuff" == NULL);
start = FFECOM_gfrt, end = FFECOM_gfrt;
break;
}
ffeste_io_endgfrt_ = end;
#define specified(something) (info->write_spec[something].kw_or_val_present)
iostat = specified (FFESTP_writeixIOSTAT);
errl = specified (FFESTP_writeixERR);
#undef specified
ffeste_start_stmt_ ();
ffeste_io_end_ = NULL_TREE;
if (errl)
{
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->write_spec[FFESTP_writeixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->write_spec[FFESTP_writeixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("write", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
if (unit == FFESTV_unitCHAREXPR)
cilist = ffeste_io_icilist_ (errl || iostat,
info->write_spec[FFESTP_writeixUNIT].u.expr,
FALSE, format,
&info->write_spec[FFESTP_writeixFORMAT]);
else
cilist = ffeste_io_cilist_ (errl || iostat, unit,
info->write_spec[FFESTP_writeixUNIT].u.expr,
6, FALSE, format,
&info->write_spec[FFESTP_writeixFORMAT],
rec,
info->write_spec[FFESTP_writeixREC].u.expr);
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
void
ffeste_R910_item (ffebld expr, ffelexToken expr_token)
{
ffeste_check_item_ ();
if (expr == NULL)
return;
if (ffebld_op (expr) == FFEBLD_opANY)
return;
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
{
ffeste_start_stmt_ ();
ffecom_prepare_arg_ptr_to_expr (expr);
ffecom_prepare_end ();
ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
ffeste_end_stmt_ ();
}
}
void
ffeste_R910_finish ()
{
ffeste_check_finish_ ();
if (ffeste_io_endgfrt_ != FFECOM_gfrt)
ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
assert (ffeste_io_err_ == NULL_TREE);
}
ffeste_end_stmt_ ();
}
void
ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
{
ffecomGfrt start;
ffecomGfrt end;
tree cilist;
ffeste_check_start_ ();
ffeste_emit_line_note_ ();
switch (format)
{
case FFESTV_formatLABEL:
case FFESTV_formatCHAREXPR:
case FFESTV_formatINTEXPR:
ffeste_io_driver_ = ffeste_io_dofio_;
start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
break;
case FFESTV_formatASTERISK:
ffeste_io_driver_ = ffeste_io_dolio_;
start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
break;
case FFESTV_formatNAMELIST:
ffeste_io_driver_ = NULL;
start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
break;
default:
assert ("Weird stuff" == NULL);
start = FFECOM_gfrt, end = FFECOM_gfrt;
break;
}
ffeste_io_endgfrt_ = end;
ffeste_start_stmt_ ();
ffeste_io_end_ = NULL_TREE;
ffeste_io_err_ = NULL_TREE;
ffeste_io_abort_ = NULL_TREE;
ffeste_io_abort_is_temp_ = FALSE;
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
&info->print_spec[FFESTP_printixFORMAT],
FALSE, NULL);
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
void
ffeste_R911_item (ffebld expr, ffelexToken expr_token)
{
ffeste_check_item_ ();
if (expr == NULL)
return;
if (ffebld_op (expr) == FFEBLD_opANY)
return;
if (ffebld_op (expr) == FFEBLD_opIMPDO)
ffeste_io_impdo_ (expr, expr_token);
else
{
ffeste_start_stmt_ ();
ffecom_prepare_arg_ptr_to_expr (expr);
ffecom_prepare_end ();
ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
ffeste_end_stmt_ ();
}
}
void
ffeste_R911_finish ()
{
ffeste_check_finish_ ();
if (ffeste_io_endgfrt_ != FFECOM_gfrt)
ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
NULL_TREE),
FALSE);
ffeste_end_stmt_ ();
}
void
ffeste_R919 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
}
void
ffeste_R920 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
}
void
ffeste_R921 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
}
void
ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
{
tree args;
bool iostat;
bool errl;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
#define specified(something) (info->inquire_spec[something].kw_or_val_present)
iostat = specified (FFESTP_inquireixIOSTAT);
errl = specified (FFESTP_inquireixERR);
#undef specified
ffeste_start_stmt_ ();
if (errl)
{
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->inquire_spec[FFESTP_inquireixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
ffeste_io_err_ = NULL_TREE;
if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
else
ffeste_io_abort_ = NULL_TREE;
}
if (iostat)
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = ffecom_expr
(info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
}
else if (ffeste_io_abort_ != NULL_TREE)
{
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
args
= ffeste_io_inlist_ (errl || iostat,
&info->inquire_spec[FFESTP_inquireixUNIT],
&info->inquire_spec[FFESTP_inquireixFILE],
&info->inquire_spec[FFESTP_inquireixEXIST],
&info->inquire_spec[FFESTP_inquireixOPENED],
&info->inquire_spec[FFESTP_inquireixNUMBER],
&info->inquire_spec[FFESTP_inquireixNAMED],
&info->inquire_spec[FFESTP_inquireixNAME],
&info->inquire_spec[FFESTP_inquireixACCESS],
&info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
&info->inquire_spec[FFESTP_inquireixDIRECT],
&info->inquire_spec[FFESTP_inquireixFORM],
&info->inquire_spec[FFESTP_inquireixFORMATTED],
&info->inquire_spec[FFESTP_inquireixUNFORMATTED],
&info->inquire_spec[FFESTP_inquireixRECL],
&info->inquire_spec[FFESTP_inquireixNEXTREC],
&info->inquire_spec[FFESTP_inquireixBLANK]);
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
assert (ffeste_io_err_ == NULL_TREE);
}
ffeste_end_stmt_ ();
}
void
ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
{
ffeste_check_start_ ();
assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
ffeste_emit_line_note_ ();
}
void
ffeste_R923B_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
}
void
ffeste_R923B_finish ()
{
ffeste_check_finish_ ();
}
void
ffeste_R1001 (ffests s)
{
tree t;
tree ttype;
tree maxindex;
tree var;
ffeste_check_simple_ ();
assert (ffeste_label_formatdef_ != NULL);
ffeste_emit_line_note_ ();
t = build_string (ffests_length (s), ffests_text (s));
TREE_TYPE (t)
= build_type_variant (build_array_type
(char_type_node,
build_range_type (integer_type_node,
integer_one_node,
build_int_2 (ffests_length (s),
0))),
1, 0);
TREE_CONSTANT (t) = 1;
TREE_STATIC (t) = 1;
var = ffecom_lookup_label (ffeste_label_formatdef_);
if ((var != NULL_TREE)
&& (TREE_CODE (var) == VAR_DECL))
{
DECL_INITIAL (var) = t;
maxindex = build_int_2 (ffests_length (s) - 1, 0);
ttype = TREE_TYPE (var);
TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
integer_zero_node,
maxindex);
if (!TREE_TYPE (maxindex))
TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
layout_type (ttype);
rest_of_decl_compilation (var, NULL, 1, 0);
expand_decl (var);
expand_decl_init (var);
}
ffeste_label_formatdef_ = NULL;
}
void
ffeste_R1103 ()
{
}
void
ffeste_R1112 ()
{
}
void
ffeste_R1212 (ffebld expr)
{
ffebld args;
ffebld arg;
ffebld labels = NULL;
ffebld prevlabels = NULL;
ffebld prevargs = NULL;
ffeste_check_simple_ ();
args = ffebld_right (expr);
ffeste_emit_line_note_ ();
for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
{
if (((arg = ffebld_head (args)) == NULL)
|| (ffebld_op (arg) != FFEBLD_opLABTER))
{
if (prevargs == NULL)
{
prevargs = args;
ffebld_set_right (expr, args);
}
else
{
ffebld_set_trail (prevargs, args);
prevargs = args;
}
}
else
{
if (prevlabels == NULL)
{
prevlabels = labels = args;
}
else
{
ffebld_set_trail (prevlabels, args);
prevlabels = args;
}
}
}
if (prevlabels == NULL)
labels = NULL;
else
ffebld_set_trail (prevlabels, NULL);
if (prevargs == NULL)
ffebld_set_right (expr, NULL);
else
ffebld_set_trail (prevargs, NULL);
ffeste_start_stmt_ ();
ffecom_prepare_expr (expr);
ffecom_prepare_end ();
if (labels == NULL)
expand_expr_stmt (ffecom_expr (expr));
else
{
tree texpr;
tree value;
tree tlabel;
int caseno;
int pushok;
tree duplicate;
ffebld label;
texpr = ffecom_expr (expr);
expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
for (caseno = 1, label = labels;
label != NULL;
++caseno, label = ffebld_trail (label))
{
value = build_int_2 (caseno, 0);
tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
pushok = pushcase (value, convert, tlabel, &duplicate);
assert (pushok == 0);
tlabel
= ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
if ((tlabel == NULL_TREE)
|| (TREE_CODE (tlabel) == ERROR_MARK))
continue;
TREE_USED (tlabel) = 1;
expand_goto (tlabel);
}
expand_end_case (texpr);
}
ffeste_end_stmt_ ();
}
void
ffeste_R1221 ()
{
}
void
ffeste_R1225 ()
{
}
void
ffeste_R1226 (ffesymbol entry)
{
tree label;
ffeste_check_simple_ ();
label = ffesymbol_hook (entry).length_tree;
ffeste_emit_line_note_ ();
if (label == error_mark_node)
return;
DECL_INITIAL (label) = error_mark_node;
emit_nop ();
expand_label (label);
}
void
ffeste_R1227 (ffestw block UNUSED, ffebld expr)
{
tree rtn;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
ffeste_start_stmt_ ();
ffecom_prepare_return_expr (expr);
ffecom_prepare_end ();
rtn = ffecom_return_expr (expr);
if ((rtn == NULL_TREE)
|| (rtn == error_mark_node))
expand_null_return ();
else
{
tree result = DECL_RESULT (current_function_decl);
if ((result != error_mark_node)
&& (TREE_TYPE (result) != error_mark_node))
expand_return (ffecom_modify (NULL_TREE,
result,
convert (TREE_TYPE (result),
rtn)));
else
expand_null_return ();
}
ffeste_end_stmt_ ();
}
#if FFESTR_VXT
void
ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
}
void
ffeste_V018_item (ffebld expr)
{
ffeste_check_item_ ();
}
void
ffeste_V018_finish ()
{
ffeste_check_finish_ ();
}
void
ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
}
void
ffeste_V019_item (ffebld expr)
{
ffeste_check_item_ ();
}
void
ffeste_V019_finish ()
{
ffeste_check_finish_ ();
}
#endif
void
ffeste_V020_start (ffestpTypeStmt *info UNUSED,
ffestvFormat format UNUSED)
{
ffeste_check_start_ ();
}
void
ffeste_V020_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
}
void
ffeste_V020_finish ()
{
ffeste_check_finish_ ();
}
#if FFESTR_VXT
void
ffeste_V021 (ffestpDeleteStmt *info)
{
ffeste_check_simple_ ();
}
void
ffeste_V022 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
}
void
ffeste_V023_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
}
void
ffeste_V023_item (ffebld expr)
{
ffeste_check_item_ ();
}
void
ffeste_V023_finish ()
{
ffeste_check_finish_ ();
}
void
ffeste_V024_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
}
void
ffeste_V024_item (ffebld expr)
{
ffeste_check_item_ ();
}
void
ffeste_V024_finish ()
{
ffeste_check_finish_ ();
}
void
ffeste_V025_start ()
{
ffeste_check_start_ ();
}
void
ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
{
ffeste_check_item_ ();
}
void
ffeste_V025_finish ()
{
ffeste_check_finish_ ();
}
void
ffeste_V026 (ffestpFindStmt *info)
{
ffeste_check_simple_ ();
}
#endif
#ifdef ENABLE_CHECKING
void
ffeste_terminate_2 (void)
{
assert (! ffeste_top_block_);
}
#endif
#include "gt-f-ste.h"