d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
e07ec61d37
freebsd-skq/contrib/gcc/f/ste.c

4621 lines
120 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* ste.c -- Implementation File (module.c template V1.0)
Copyright (C) 1995, 1996, 2000, 2002 Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.
Related Modules:
ste.c
Description:
Implements the various statements and such like.
Modifications:
*/
/* Include files. */
#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"
/* Externals defined here. */
/* Simple definitions and enumerations. */
typedef enum
{
FFESTE_stateletSIMPLE_, /* Expecting simple/start. */
FFESTE_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
FFESTE_stateletITEM_, /* Expecting item/itemstart/finish. */
FFESTE_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
FFESTE_
} ffesteStatelet_;
/* Internal typedefs. */
/* Private include files. */
/* Internal structure definitions. */
/* Static objects accessed by functions in this module. */
static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
static ffelab ffeste_label_formatdef_ = NULL;
static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */
static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */
static tree ffeste_io_abort_; /* abort-io label or NULL_TREE. */
static bool ffeste_io_abort_is_temp_; /* abort-io label is a temp. */
static tree ffeste_io_end_; /* END= label or NULL_TREE. */
static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */
static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */
static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */
/* Static functions (internal). */
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);
/* Internal macros. */
#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)
/* Start a Fortran block. */
#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 ();
}
/* End a Fortran block. */
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 ();
}
/* Start a Fortran statement.
Starts a back-end block, so temporaries can be managed, clean-ups
properly handled, etc. Nesting of statements *is* allowed -- the
handling of I/O items, even implied-DO I/O lists, within a READ,
PRINT, or WRITE statement is one example. */
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 ();
}
/* End a Fortran statement. */
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 /* ! defined (ENABLE_CHECKING) */
#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 /* ! defined (ENABLE_CHECKING) */
/* Begin an iterative DO loop. Pass the block to start if
applicable. */
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;
/* Want to have tvar, tincr, and niters for the whole loop body. */
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;
}
/* Check whether incr is known to be zero, complain and fix. */
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);
/* Want to have tstart, tend for just this statement. */
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;
}
/* For warnings only, nothing else happens here. */
{
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));
/* Warn if loop never executed, since we've done the evaluation
of the unofficial iteration count already. */
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 ();
}
}
/* Warn if end plus incr would overflow. */
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 ();
}
}
/* Do the initial assignment into the DO var. */
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 /* New, F90-approved approach: convert to default INTEGER. */
if (TREE_TYPE (tvar) != error_mark_node)
expr = convert (ffecom_integer_type_node, expr);
#else /* Old approach; convert to INTEGER unless that's a narrowing. */
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)))))))
/* Convert unless promoting INTEGER type of any kind downward to
default INTEGER; else leave as, say, INTEGER*8 (long long int). */
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;
}
}
/* End an iterative DO loop. Pass the same iteration variable and increment
value trees that were generated in the paired _begin_ call. */
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);
/* Lose the stuff we just built. */
ffeste_end_stmt_ ();
expand_end_loop ();
/* Lose the tvar and incr_saved trees. */
if (block)
ffeste_end_block_ (block);
else
ffeste_end_stmt_ ();
}
/* Generate call to run-time I/O routine. */
static void
ffeste_io_call_ (tree call, bool do_check)
{
/* Generate the call and optional assignment into iostat var. */
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;
/* Generate optional test. */
expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
expand_goto (ffeste_io_abort_);
expand_end_cond ();
}
/* Handle implied-DO in I/O list.
Expands code to start up the DO loop. Then for each item in the
DO loop, handles appropriately (possibly including recursively calling
itself). Then expands code to end the DO loop. */
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 the DO loop. */
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");
/* Handle the list of items. */
for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
{
item = ffebld_head (list);
if (item == NULL)
continue;
/* Strip parens off items such as in "READ *,(A)". This is really a bug
in the user's code, but I've been told lots of code does this. */
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_ ();
}
}
/* Generate end of implied-do construct. */
ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
}
/* I/O driver for formatted I/O item (do_fio)
Returns a tree for a CALL_EXPR to the do_fio function, which handles
a formatted I/O list item, along with the appropriate arguments for
the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
for the CALL_EXPR, expand (emit) the expression, emit any assignment
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
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) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
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 /* Assume that while it is possible that char * is wider than
ftnlen, no object in Fortran space can get big enough for its
size to be wider than ftnlen. I really hope nobody wastes
time debugging a case where it can! */
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);
}
/* I/O driver for list-directed I/O item (do_lio)
Returns a tree for a CALL_EXPR to the do_lio function, which handles
a list-directed I/O list item, along with the appropriate arguments for
the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
for the CALL_EXPR, expand (emit) the expression, emit any assignment
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
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) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
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 /* Assume that while it is possible that char * is wider than
ftnlen, no object in Fortran space can get big enough for its
size to be wider than ftnlen. I really hope nobody wastes
time debugging a case where it can! */
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);
}
/* I/O driver for unformatted I/O item (do_uio)
Returns a tree for a CALL_EXPR to the do_uio function, which handles
an unformatted I/O list item, along with the appropriate arguments for
the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
for the CALL_EXPR, expand (emit) the expression, emit any assignment
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
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) /* Already filled in for CHARACTER type. */
{ /* "(ftnlen) sizeof(type)" */
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 /* Assume that while it is possible that char * is wider than
ftnlen, no object in Fortran space can get big enough for its
size to be wider than ftnlen. I really hope nobody wastes
time debugging a case where it can! */
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);
}
/* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
Returns a tree suitable as an argument list containing a pointer to
a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
static tree
ffeste_io_ialist_ (bool have_err,
ffestvUnit unit,
ffebld unit_expr,
int unit_dflt)
{
static tree f2c_alist_struct = NULL_TREE;
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);
ggc_add_tree_root (&f2c_alist_struct, 1);
f2c_alist_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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);
/* Prepare run-time expressions. */
if (! unitexp)
ffecom_prepare_expr (unit_expr);
ffecom_prepare_end ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Make arglist with ptr to external-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
an external-I/O control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
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 f2c_cilist_struct = NULL_TREE;
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);
ggc_add_tree_root (&f2c_cilist_struct, 1);
f2c_cilist_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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);
/* Prepare run-time expressions. */
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 ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Make arglist with ptr to CLOSE control list.
Returns a tree suitable as an argument list containing a pointer to
a CLOSE-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
static tree
ffeste_io_cllist_ (bool have_err,
ffebld unit_expr,
ffestpFile *stat_spec)
{
static tree f2c_close_struct = NULL_TREE;
tree t;
tree ttype;
tree field;
tree inits, initn;
tree ignore; /* Ignore length info for certain fields. */
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);
ggc_add_tree_root (&f2c_close_struct, 1);
f2c_close_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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);
/* Prepare run-time expressions. */
if (! unitexp)
ffecom_prepare_expr (unit_expr);
if (! statexp)
ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
ffecom_prepare_end ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Make arglist with ptr to internal-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
an internal-I/O control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
static tree
ffeste_io_icilist_ (bool have_err,
ffebld unit_expr,
bool have_end,
ffestvFormat format,
ffestpFile *format_spec)
{
static tree f2c_icilist_struct = NULL_TREE;
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);
ggc_add_tree_root (&f2c_icilist_struct, 1);
f2c_icilist_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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;
}
/* Now see if we can fully initialize the number of elements, or
if we have to compute that at run time. */
if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
|| (unitexp
&& TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
{
/* Not an array, so just one element. */
unitnuminit = ffecom_integer_one_node;
unitnumexp = unitnuminit;
}
else if (unitexp && unitlenexp)
{
/* An array, but all the info is constant, so compute now. */
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
{
/* Put off computing until run time. */
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);
/* Prepare run-time expressions. */
if (! unitexp)
ffecom_prepare_arg_ptr_to_expr (unit_expr);
ffeste_f2c_prepare_format_ (format_spec, formatexp);
ffecom_prepare_end ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Make arglist with ptr to INQUIRE control list
Returns a tree suitable as an argument list containing a pointer to
an INQUIRE-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
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 f2c_inquire_struct = NULL_TREE;
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);
ggc_add_tree_root (&f2c_inquire_struct, 1);
f2c_inquire_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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);
/* Prepare run-time expressions. */
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 ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Make arglist with ptr to OPEN control list
Returns a tree suitable as an argument list containing a pointer to
an OPEN-statement control list. First, generates that control
list, if necessary, along with any static and run-time initializations
that are needed as specified by the arguments to this function.
Must ensure that all expressions are prepared before being evaluated,
for any whose evaluation might result in the generation of temporaries.
Note that this means this function causes a transition, within the
current block being code-generated via the back end, from the
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
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 tree f2c_open_struct = NULL_TREE;
tree t;
tree ttype;
tree field;
tree inits, initn;
tree ignore; /* Ignore length info for certain fields. */
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);
ggc_add_tree_root (&f2c_open_struct, 1);
f2c_open_struct = ref;
}
/* Try to do as much compile-time initialization of the structure
as possible, to save run time. */
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);
/* Prepare run-time expressions. */
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 ();
/* Now evaluate run-time expressions as needed. */
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;
}
/* Generate code for BACKSPACE/ENDFILE/REWIND. */
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
/* ~~For now, we assume the unit number is specified and is not ASTERISK,
because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
without any unit specifier. f2c, however, supports the former
construct. When it is time to add this feature to the FFE, which
probably is fairly easy, ffestc_R919 and company will want to pass an
ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
ffeste_R919 and company, and they will want to pass that same value to
this function, and that argument will replace the constant _unitINTEXPR_
in the call below. Right now, the default unit number, 6, is ignored. */
ffeste_start_stmt_ ();
if (errl)
{
/* Have ERR= specification. */
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->beru_spec[FFESTP_beruixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
/* No ERR= specification. */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("beru", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT= or ERR= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
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_ ();
}
/* END DO statement
Also invoked by _labeldef_branch_finish_ (or, in cases
of errors, other _labeldef_ functions) when the label definition is
for a DO-target (LOOPEND) label, once per matching/outstanding DO
block on the stack. */
void
ffeste_do (ffestw block)
{
ffeste_emit_line_note_ ();
if (ffestw_do_tvar (block) == 0)
{
expand_end_loop (); /* DO WHILE and just DO. */
ffeste_end_block_ (block);
}
else
ffeste_end_iterdo_ (block,
ffestw_do_tvar (block),
ffestw_do_incr_saved (block),
ffestw_do_count_var (block));
}
/* End of statement following logical IF.
Applies to *only* logical IF, not to IF-THEN. */
void
ffeste_end_R807 ()
{
ffeste_emit_line_note_ ();
expand_end_cond ();
ffeste_end_block_ (NULL);
}
/* Generate "code" for branch label definition. */
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);
}
/* Generate "code" for FORMAT label definition. */
void
ffeste_labeldef_format (ffelab label)
{
ffeste_label_formatdef_ = label;
}
/* Assignment statement (outside of WHERE). */
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_ ();
}
/* Block IF (IF-THEN) statement. */
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);
/* No fake `else' constructs introduced (yet). */
ffestw_set_ifthen_fake_else (block, 0);
}
/* ELSE IF statement. */
void
ffeste_R804 (ffestw block, ffebld expr)
{
tree temp;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
/* Since ELSEIF(expr) might require preparations for expr,
implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
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
{
/* In this case, we could probably have used expand_start_elseif
instead, saving the need for a fake `else' construct. But,
until it's clear that'd improve performance, it's easier this
way, since we have to expand_start_else before we get to this
test, given the current design. */
ffeste_end_stmt_ ();
temp = ffecom_truth_value (ffecom_expr (expr));
}
expand_start_cond (temp, 0);
/* Increment number of fake `else' constructs introduced. */
ffestw_set_ifthen_fake_else (block,
ffestw_ifthen_fake_else (block) + 1);
}
/* ELSE statement. */
void
ffeste_R805 (ffestw block UNUSED)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_start_else ();
}
/* END IF statement. */
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);
}
}
/* Logical IF statement. */
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);
}
/* SELECT CASE statement. */
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)
{
/* ~~~Someday handle CHARACTER*1, CHARACTER*N */
/* xgettext:no-c-format */
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);
}
}
/* CASE statement.
If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
the start of the first_stmt list in the select object at the top of
the stack that match casenum. */
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;
/* ~~~Someday handle CHARACTER*1, CHARACTER*N */
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) /* Intentional CASE DEFAULT. */
{
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 == 0);
c = c->next_stmt;
/* Unlink prev. */
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));
}
/* END SELECT statement. */
void
ffeste_R811 (ffestw block)
{
ffeste_emit_line_note_ ();
/* ~~~Someday handle CHARACTER*1, CHARACTER*N */
if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
expand_end_case (ffestw_select_texpr (block));
ffeste_end_block_ (block);
}
/* Iterative DO statement. */
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");
}
/* DO WHILE statement. */
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);
}
/* END DO statement.
This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
CONTINUE (except that it has to have a label that is the target of
one or more iterative DO statement), not the Fortran-90 structured
END DO, which is handled elsewhere, as is the actual mechanism of
ending an iterative DO statement, even one that ends at a label. */
void
ffeste_R825 ()
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
emit_nop ();
}
/* CYCLE statement. */
void
ffeste_R834 (ffestw block)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_continue_loop (ffestw_do_hook (block));
}
/* EXIT statement. */
void
ffeste_R835 (ffestw block)
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
expand_exit_loop (ffestw_do_hook (block));
}
/* GOTO statement. */
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;
}
}
/* Computed GOTO statement. */
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_ ();
}
/* ASSIGN statement. */
void
ffeste_R838 (ffelab label, ffebld target)
{
tree expr_tree;
tree label_tree;
tree target_tree;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
/* No need to call ffeste_start_stmt_(), as the sorts of expressions
seen here should never require use of temporaries. */
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);
}
}
/* Assigned GOTO statement. */
void
ffeste_R839 (ffebld target)
{
tree t;
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
/* No need to call ffeste_start_stmt_(), as the sorts of expressions
seen here should never require use of temporaries. */
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));
}
/* Arithmetic IF statement. */
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
{
/* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
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)
{
/* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
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)
{
/* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
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
{
/* Use a SAVE_EXPR in combo with:
IF (expr.LT.0) THEN GOTO neg
ELSEIF (expr.GT.0) THEN GOTO pos
ELSE GOTO zero. */
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_ ();
}
/* CONTINUE statement. */
void
ffeste_R841 ()
{
ffeste_check_simple_ ();
ffeste_emit_line_note_ ();
emit_nop ();
}
/* STOP statement. */
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);
}
/* No need to call ffeste_start_stmt_(), as the sorts of expressions
seen here should never require use of temporaries. */
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);
}
/* PAUSE statement. */
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);
}
/* No need to call ffeste_start_stmt_(), as the sorts of expressions
seen here should never require use of temporaries. */
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);
}
/* OPEN statement. */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("open", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT= or ERR= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
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]);
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
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_ ();
}
/* CLOSE statement. */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("close", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT= or ERR= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
args = ffeste_io_cllist_ (errl || iostat,
info->close_spec[FFESTP_closeixUNIT].u.expr,
&info->close_spec[FFESTP_closeixSTATUS]);
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
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_ ();
}
/* READ(...) statement -- start. */
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_ ();
/* First determine the start, per-item, and end run-time functions to
call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
case FFESTV_formatNONE: /* no FMT= */
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: /* FMT=10 */
case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
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: /* FMT=* */
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: /* FMT=FOO or NML=FOO [NAMELIST
/FOO/] */
ffeste_io_driver_ = NULL; /* No start or driver function. */
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)
{
/* Have ERR= specification. */
ffeste_io_err_
= ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
if (endl)
{
/* Have both ERR= and END=. Need a temp label to handle both. */
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
{
/* Have ERR= but no END=. */
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
{
/* No ERR= specification. */
ffeste_io_err_ = NULL_TREE;
if (endl)
{
/* Have END= but no ERR=. */
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
{
/* Have no ERR= or END=. */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR= and/or END=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("read", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT=, ERR=, or END= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
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);
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* READ statement -- I/O item. */
void
ffeste_R909_item (ffebld expr, ffelexToken expr_token)
{
ffeste_check_item_ ();
if (expr == NULL)
return;
/* Strip parens off items such as in "READ *,(A)". This is really a bug
in the user's code, but I've been told lots of code does this. */
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_ ();
}
}
/* READ statement -- end. */
void
ffeste_R909_finish ()
{
ffeste_check_finish_ ();
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
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 we've got a temp label, generate its code here and have it fan out
to the END= or ERR= label as appropriate. */
if (ffeste_io_abort_is_temp_)
{
DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
emit_nop ();
expand_label (ffeste_io_abort_);
/* "if (iostat<0) goto end_label;". */
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 (iostat>0) goto err_label;". */
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_ ();
}
/* WRITE statement -- start. */
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_ ();
/* First determine the start, per-item, and end run-time functions to
call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
case FFESTV_formatNONE: /* no FMT= */
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: /* FMT=10 */
case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
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: /* FMT=* */
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: /* FMT=FOO or NML=FOO [NAMELIST
/FOO/] */
ffeste_io_driver_ = NULL; /* No start or driver function. */
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)
{
/* Have ERR= specification. */
ffeste_io_err_
= ffeste_io_abort_
= ffecom_lookup_label
(info->write_spec[FFESTP_writeixERR].u.label);
ffeste_io_abort_is_temp_ = FALSE;
}
else
{
/* No ERR= specification. */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("write", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT= or ERR= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
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);
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* WRITE statement -- I/O item. */
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_ ();
}
}
/* WRITE statement -- end. */
void
ffeste_R910_finish ()
{
ffeste_check_finish_ ();
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
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 we've got a temp label, generate its code here. */
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_ ();
}
/* PRINT statement -- start. */
void
ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
{
ffecomGfrt start;
ffecomGfrt end;
tree cilist;
ffeste_check_start_ ();
ffeste_emit_line_note_ ();
/* First determine the start, per-item, and end run-time functions to
call. The per-item function is picked by choosing an ffeste function
to call to handle a given item; it knows how to generate a call to the
appropriate run-time function, and is called an "I/O driver". */
switch (format)
{
case FFESTV_formatLABEL: /* FMT=10 */
case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
ffeste_io_driver_ = ffeste_io_dofio_;
start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
break;
case FFESTV_formatASTERISK: /* FMT=* */
ffeste_io_driver_ = ffeste_io_dolio_;
start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
break;
case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
/FOO/] */
ffeste_io_driver_ = NULL; /* No start or driver function. */
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;
/* Now prescan, then convert, all the arguments. */
cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
&info->print_spec[FFESTP_printixFORMAT],
FALSE, NULL);
/* If there is no end function, then there are no item functions (i.e.
it's a NAMELIST), and vice versa by the way. In this situation, don't
generate the "if (iostat != 0) goto label;" if the label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
(! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* PRINT statement -- I/O item. */
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_ ();
}
}
/* PRINT statement -- end. */
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_ ();
}
/* BACKSPACE statement. */
void
ffeste_R919 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
}
/* ENDFILE statement. */
void
ffeste_R920 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
}
/* REWIND statement. */
void
ffeste_R921 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
}
/* INQUIRE statement (non-IOLENGTH version). */
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)
{
/* Have IOSTAT= specification. */
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)
{
/* Have no IOSTAT= but have ERR=. */
ffeste_io_iostat_is_temp_ = TRUE;
ffeste_io_iostat_
= ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
FFETARGET_charactersizeNONE, -1);
}
else
{
/* No IOSTAT= or ERR= specification. */
ffeste_io_iostat_is_temp_ = FALSE;
ffeste_io_iostat_ = NULL_TREE;
}
/* Now prescan, then convert, all the arguments. */
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]);
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
! ffeste_io_abort_is_temp_);
/* If we've got a temp label, generate its code here. */
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_ ();
}
/* INQUIRE(IOLENGTH=expr) statement -- start. */
void
ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
{
ffeste_check_start_ ();
assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
ffeste_emit_line_note_ ();
}
/* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
void
ffeste_R923B_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
}
/* INQUIRE(IOLENGTH=expr) statement -- end. */
void
ffeste_R923B_finish ()
{
ffeste_check_finish_ ();
}
/* ffeste_R1001 -- FORMAT statement
ffeste_R1001(format_list); */
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;
}
/* END PROGRAM. */
void
ffeste_R1103 ()
{
}
/* END BLOCK DATA. */
void
ffeste_R1112 ()
{
}
/* CALL statement. */
void
ffeste_R1212 (ffebld expr)
{
ffebld args;
ffebld arg;
ffebld labels = NULL; /* First in list of LABTERs. */
ffebld prevlabels = NULL;
ffebld prevargs = NULL;
ffeste_check_simple_ ();
args = ffebld_right (expr);
ffeste_emit_line_note_ ();
/* Here we split the list at ffebld_right(expr) into two lists: one at
ffebld_right(expr) consisting of all items that are not LABTERs, the
other at labels consisting of all items that are LABTERs. Then, if
the latter list is NULL, we have an ordinary call, else we have a call
with alternate returns. */
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_ ();
/* No temporaries are actually needed at this level, but we go
through the motions anyway, just to be sure in case they do
get made. Temporaries needed for arguments should be in the
scopes of inner blocks, and if clean-up actions are supported,
such as CALL-ing an intrinsic that writes to an argument of one
type when a variable of a different type is provided (requiring
assignment to the variable from a temporary after the library
routine returns), the clean-up must be done by the expression
evaluator, generally, to handle alternate returns (which we hope
won't ever be supported by intrinsics, but might be a similar
issue, such as CALL-ing an F90-style subroutine with an INTERFACE
block). That implies the expression evaluator will have to
recognize the need for its own temporary anyway, meaning it'll
construct a block within the one constructed here. */
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_ ();
}
/* END FUNCTION. */
void
ffeste_R1221 ()
{
}
/* END SUBROUTINE. */
void
ffeste_R1225 ()
{
}
/* ENTRY statement. */
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);
}
/* RETURN statement. */
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_ ();
}
/* REWRITE statement -- start. */
#if FFESTR_VXT
void
ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
}
/* REWRITE statement -- I/O item. */
void
ffeste_V018_item (ffebld expr)
{
ffeste_check_item_ ();
}
/* REWRITE statement -- end. */
void
ffeste_V018_finish ()
{
ffeste_check_finish_ ();
}
/* ACCEPT statement -- start. */
void
ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
}
/* ACCEPT statement -- I/O item. */
void
ffeste_V019_item (ffebld expr)
{
ffeste_check_item_ ();
}
/* ACCEPT statement -- end. */
void
ffeste_V019_finish ()
{
ffeste_check_finish_ ();
}
#endif
/* TYPE statement -- start. */
void
ffeste_V020_start (ffestpTypeStmt *info UNUSED,
ffestvFormat format UNUSED)
{
ffeste_check_start_ ();
}
/* TYPE statement -- I/O item. */
void
ffeste_V020_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
}
/* TYPE statement -- end. */
void
ffeste_V020_finish ()
{
ffeste_check_finish_ ();
}
/* DELETE statement. */
#if FFESTR_VXT
void
ffeste_V021 (ffestpDeleteStmt *info)
{
ffeste_check_simple_ ();
}
/* UNLOCK statement. */
void
ffeste_V022 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
}
/* ENCODE statement -- start. */
void
ffeste_V023_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
}
/* ENCODE statement -- I/O item. */
void
ffeste_V023_item (ffebld expr)
{
ffeste_check_item_ ();
}
/* ENCODE statement -- end. */
void
ffeste_V023_finish ()
{
ffeste_check_finish_ ();
}
/* DECODE statement -- start. */
void
ffeste_V024_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
}
/* DECODE statement -- I/O item. */
void
ffeste_V024_item (ffebld expr)
{
ffeste_check_item_ ();
}
/* DECODE statement -- end. */
void
ffeste_V024_finish ()
{
ffeste_check_finish_ ();
}
/* DEFINEFILE statement -- start. */
void
ffeste_V025_start ()
{
ffeste_check_start_ ();
}
/* DEFINE FILE statement -- item. */
void
ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
{
ffeste_check_item_ ();
}
/* DEFINE FILE statement -- end. */
void
ffeste_V025_finish ()
{
ffeste_check_finish_ ();
}
/* FIND statement. */
void
ffeste_V026 (ffestpFindStmt *info)
{
ffeste_check_simple_ ();
}
#endif
#ifdef ENABLE_CHECKING
void
ffeste_terminate_2 (void)
{
assert (! ffeste_top_block_);
}
#endif
Reference in New Issue View Git Blame Copy Permalink