5420 lines
143 KiB
C
5420 lines
143 KiB
C
/* ste.c -- Implementation File (module.c template V1.0)
|
||
Copyright (C) 1995, 1996 Free Software Foundation, Inc.
|
||
Contributed by James Craig Burley (burley@gnu.org).
|
||
|
||
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:
|
||
*/
|
||
|
||
/* As of 0.5.4, any statement that calls on ffecom to transform an
|
||
expression might need to be wrapped in ffecom_push_calltemps ()
|
||
and ffecom_pop_calltemps () as are some other cases. That is
|
||
the case when the transformation might involve generation of
|
||
a temporary that must be auto-popped, the specific case being
|
||
when a COMPLEX operation requiring a call to libf2c being
|
||
generated, whereby a temp is needed to hold the result since
|
||
libf2c doesn't return COMPLEX results directly. Cases where it
|
||
is known that ffecom_expr () won't need to do this, such as
|
||
the CALL statement (where it's the transformation of the
|
||
call expr itself that does the wrapping), don't need to bother
|
||
with this wrapping. Forgetting to do the wrapping currently
|
||
means a crash at an assertion when the wrapping would be helpful
|
||
to keep temporaries from being wasted -- see ffecom_push_tempvar. */
|
||
|
||
/* Include files. */
|
||
|
||
#include "proj.h"
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#include "rtl.j"
|
||
#include "toplev.j"
|
||
#endif
|
||
|
||
#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_;
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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. */
|
||
#endif
|
||
|
||
/* Static functions (internal). */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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,
|
||
char *msg);
|
||
static void ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar);
|
||
static void ffeste_io_call_ (tree call, bool do_check);
|
||
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 void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
|
||
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);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
static void ffeste_subr_file_ (char *kw, ffestpFile *spec);
|
||
#else
|
||
#error
|
||
#endif
|
||
|
||
/* Internal macros. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#define ffeste_emit_line_note_() \
|
||
emit_line_note (input_filename, lineno)
|
||
#endif
|
||
#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_charnolenspec_(Spec,Exp,Init) \
|
||
do \
|
||
{ \
|
||
if (Spec->kw_or_val_present) \
|
||
Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&ignore); \
|
||
else \
|
||
Exp = null_pointer_node; \
|
||
if (TREE_CONSTANT(Exp)) \
|
||
{ \
|
||
Init = Exp; \
|
||
Exp = NULL_TREE; \
|
||
} \
|
||
else \
|
||
{ \
|
||
Init = null_pointer_node; \
|
||
constantp = FALSE; \
|
||
} \
|
||
} while(0)
|
||
|
||
#define ffeste_f2c_charspec_(Spec,Exp,Init,Lenexp,Leninit) \
|
||
do \
|
||
{ \
|
||
if (Spec->kw_or_val_present) \
|
||
Exp = ffecom_arg_ptr_to_expr(Spec->u.expr,&Lenexp); \
|
||
else \
|
||
{ \
|
||
Exp = null_pointer_node; \
|
||
Lenexp = ffecom_f2c_ftnlen_zero_node; \
|
||
} \
|
||
if (TREE_CONSTANT(Exp)) \
|
||
{ \
|
||
Init = Exp; \
|
||
Exp = NULL_TREE; \
|
||
} \
|
||
else \
|
||
{ \
|
||
Init = null_pointer_node; \
|
||
constantp = FALSE; \
|
||
} \
|
||
if ((Lenexp != NULL_TREE) && TREE_CONSTANT(Lenexp)) \
|
||
{ \
|
||
Leninit = Lenexp; \
|
||
Lenexp = NULL_TREE; \
|
||
} \
|
||
else \
|
||
{ \
|
||
Leninit = ffecom_f2c_ftnlen_zero_node; \
|
||
constantp = FALSE; \
|
||
} \
|
||
} while(0)
|
||
|
||
#define ffeste_f2c_exp_(Field,Exp) \
|
||
do \
|
||
{ \
|
||
if (Exp != NULL_TREE) \
|
||
{ \
|
||
Exp = ffecom_modify(void_type_node,ffecom_2(COMPONENT_REF, \
|
||
TREE_TYPE(Field),t,Field),Exp); \
|
||
expand_expr_stmt(Exp); \
|
||
} \
|
||
} while(0)
|
||
|
||
#define ffeste_f2c_init_(Init) \
|
||
do \
|
||
{ \
|
||
TREE_CHAIN(initn) = build_tree_list((field = TREE_CHAIN(field)),Init); \
|
||
initn = TREE_CHAIN(initn); \
|
||
} while(0)
|
||
|
||
#define ffeste_f2c_flagspec_(Flag,Init) \
|
||
do { Init = convert (ffecom_f2c_flag_type_node, \
|
||
Flag ? integer_one_node : integer_zero_node); } \
|
||
while(0)
|
||
|
||
#define ffeste_f2c_intspec_(Spec,Exp,Init) \
|
||
do \
|
||
{ \
|
||
if (Spec->kw_or_val_present) \
|
||
Exp = ffecom_expr(Spec->u.expr); \
|
||
else \
|
||
Exp = ffecom_integer_zero_node; \
|
||
if (TREE_CONSTANT(Exp)) \
|
||
{ \
|
||
Init = Exp; \
|
||
Exp = NULL_TREE; \
|
||
} \
|
||
else \
|
||
{ \
|
||
Init = ffecom_integer_zero_node; \
|
||
constantp = FALSE; \
|
||
} \
|
||
} while(0)
|
||
|
||
#define ffeste_f2c_ptrtointspec_(Spec,Exp,Init) \
|
||
do \
|
||
{ \
|
||
if (Spec->kw_or_val_present) \
|
||
Exp = ffecom_ptr_to_expr(Spec->u.expr); \
|
||
else \
|
||
Exp = null_pointer_node; \
|
||
if (TREE_CONSTANT(Exp)) \
|
||
{ \
|
||
Init = Exp; \
|
||
Exp = NULL_TREE; \
|
||
} \
|
||
else \
|
||
{ \
|
||
Init = null_pointer_node; \
|
||
constantp = FALSE; \
|
||
} \
|
||
} while(0)
|
||
|
||
|
||
/* Begin an iterative DO loop. Pass the block to start if applicable.
|
||
|
||
NOTE: Does _two_ push_momentary () calls, which the caller must
|
||
undo (by calling ffeste_end_iterdo_). */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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,
|
||
char *msg)
|
||
{
|
||
tree tvar;
|
||
tree expr;
|
||
tree tstart;
|
||
tree tend;
|
||
tree tincr;
|
||
tree tincr_saved;
|
||
tree niters;
|
||
|
||
push_momentary (); /* Want to save these throughout the loop. */
|
||
|
||
tvar = ffecom_expr_rw (var);
|
||
tincr = ffecom_expr (incr);
|
||
|
||
/* 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);
|
||
|
||
push_momentary (); /* Want to discard the rest after the loop. */
|
||
|
||
tstart = ffecom_expr (start);
|
||
tend = ffecom_expr (end);
|
||
|
||
{ /* 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
|
||
|
||
niters = ffecom_push_tempvar (TREE_TYPE (expr),
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
expr = ffecom_modify (void_type_node, niters, expr);
|
||
expand_expr_stmt (expr);
|
||
|
||
expr = ffecom_modify (void_type_node, tvar, tstart);
|
||
expand_expr_stmt (expr);
|
||
|
||
if (block == NULL)
|
||
expand_start_loop_continue_elsewhere (0);
|
||
else
|
||
ffestw_set_do_hook (block,
|
||
expand_start_loop_continue_elsewhere (1));
|
||
|
||
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);
|
||
}
|
||
|
||
clear_momentary (); /* Discard the above now that we're done with
|
||
DO stmt. */
|
||
|
||
if (block == NULL)
|
||
{
|
||
*xtvar = tvar;
|
||
*xtincr = tincr_saved;
|
||
*xitersvar = niters;
|
||
}
|
||
else
|
||
{
|
||
ffestw_set_do_tvar (block, tvar);
|
||
ffestw_set_do_incr_saved (block, tincr_saved);
|
||
ffestw_set_do_count_var (block, niters);
|
||
}
|
||
}
|
||
|
||
#endif
|
||
|
||
/* End an iterative DO loop. Pass the same iteration variable and increment
|
||
value trees that were generated in the paired _begin_ call. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
static void
|
||
ffeste_end_iterdo_ (tree tvar, tree tincr, tree itersvar)
|
||
{
|
||
tree expr;
|
||
tree niters = itersvar;
|
||
|
||
expand_loop_continue_here ();
|
||
|
||
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);
|
||
expand_end_loop ();
|
||
|
||
ffecom_pop_tempvar (itersvar); /* Free #iters var. */
|
||
|
||
clear_momentary ();
|
||
pop_momentary (); /* Lose the stuff we just built. */
|
||
|
||
clear_momentary ();
|
||
pop_momentary (); /* Lose the tvar and incr_saved trees. */
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_call_ -- Generate call to run-time I/O routine
|
||
|
||
tree callexpr = build(CALL_EXPR,...);
|
||
ffeste_io_call_(callexpr,TRUE);
|
||
|
||
Sets TREE_SIDE_EFFECTS(callexpr) = 1. If ffeste_io_iostat_ is not
|
||
NULL_TREE, replaces callexpr with "iostat = callexpr;". Expands the
|
||
result. If ffeste_io_abort_ is not NULL_TREE and the second argument
|
||
is TRUE, generates "if (iostat != 0) goto ffeste_io_abort_;". */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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 ();
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_dofio_ -- Generate call to do_fio for formatted I/O item
|
||
|
||
ffebld expr;
|
||
tree call;
|
||
call = ffeste_io_dofio_(expr);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
variable = ffecom_arg_ptr_to_expr (expr, &size);
|
||
|
||
if ((variable == error_mark_node)
|
||
|| (size == error_mark_node))
|
||
{
|
||
ffecom_pop_calltemps ();
|
||
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 (ffecom_tree_type[bt][kt]),
|
||
size_int (TYPE_PRECISION (char_type_node)));
|
||
#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 (TREE_TYPE (TREE_TYPE (variable))), size);
|
||
num_elements = size_binop (CEIL_DIV_EXPR,
|
||
num_elements,
|
||
size_int (TYPE_PRECISION
|
||
(char_type_node)));
|
||
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);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist);
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_dolio_ -- Generate call to do_lio for list-directed I/O item
|
||
|
||
ffebld expr;
|
||
tree call;
|
||
call = ffeste_io_dolio_(expr);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
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))
|
||
{
|
||
ffecom_pop_calltemps ();
|
||
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 (ffecom_tree_type[bt][kt]),
|
||
size_int (TYPE_PRECISION (char_type_node)));
|
||
#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 (TREE_TYPE (TREE_TYPE (variable))), size);
|
||
num_elements = size_binop (CEIL_DIV_EXPR,
|
||
num_elements,
|
||
size_int (TYPE_PRECISION
|
||
(char_type_node)));
|
||
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);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist);
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_douio_ -- Generate call to do_uio for unformatted I/O item
|
||
|
||
ffebld expr;
|
||
tree call;
|
||
call = ffeste_io_douio_(expr);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
variable = ffecom_arg_ptr_to_expr (expr, &size);
|
||
|
||
if ((variable == error_mark_node)
|
||
|| (size == error_mark_node))
|
||
{
|
||
ffecom_pop_calltemps ();
|
||
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 (ffecom_tree_type[bt][kt]),
|
||
size_int (TYPE_PRECISION (char_type_node)));
|
||
#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 (TREE_TYPE (TREE_TYPE (variable))), size);
|
||
num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
|
||
size_int (TYPE_PRECISION
|
||
(char_type_node)));
|
||
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);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist);
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_ialist_ -- Make arglist with ptr to B/E/R control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_ialist_(...);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_alist_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
|
||
switch (unit)
|
||
{
|
||
case FFESTV_unitNONE:
|
||
case FFESTV_unitASTERISK:
|
||
unitinit = build_int_2 (unit_dflt, 0);
|
||
unitexp = NULL_TREE;
|
||
break;
|
||
|
||
case FFESTV_unitINTEXPR:
|
||
unitexp = ffecom_expr (unit_expr);
|
||
if (TREE_CONSTANT (unitexp))
|
||
{
|
||
unitinit = unitexp;
|
||
unitexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitinit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
break;
|
||
|
||
default:
|
||
assert ("bad unit spec" == NULL);
|
||
unitexp = NULL_TREE;
|
||
unitinit = ffecom_integer_zero_node;
|
||
break;
|
||
}
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_alist_%d", NULL,
|
||
mynumber++),
|
||
f2c_alist_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (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;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_cilist_ -- Make arglist with ptr to external I/O control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_cilist_(...);
|
||
|
||
Returns a tree suitable as an argument list containing a pointer to
|
||
an external-file 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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_cilist_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
|
||
switch (unit)
|
||
{
|
||
case FFESTV_unitNONE:
|
||
case FFESTV_unitASTERISK:
|
||
unitinit = build_int_2 (unit_dflt, 0);
|
||
unitexp = NULL_TREE;
|
||
break;
|
||
|
||
case FFESTV_unitINTEXPR:
|
||
unitexp = ffecom_expr (unit_expr);
|
||
if (TREE_CONSTANT (unitexp))
|
||
{
|
||
unitinit = unitexp;
|
||
unitexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitinit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
break;
|
||
|
||
default:
|
||
assert ("bad unit spec" == NULL);
|
||
unitexp = NULL_TREE;
|
||
unitinit = ffecom_integer_zero_node;
|
||
break;
|
||
}
|
||
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE:
|
||
formatinit = null_pointer_node;
|
||
formatexp = NULL_TREE;
|
||
break;
|
||
|
||
case FFESTV_formatLABEL:
|
||
formatexp = NULL_TREE;
|
||
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_expr (format_spec->u.expr, NULL);
|
||
if (TREE_CONSTANT (formatexp))
|
||
{
|
||
formatinit = formatexp;
|
||
formatexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
formatinit = null_pointer_node;
|
||
constantp = FALSE;
|
||
}
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
formatinit = null_pointer_node;
|
||
formatexp = NULL_TREE;
|
||
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 = NULL_TREE;
|
||
break;
|
||
|
||
default:
|
||
assert ("bad format spec" == NULL);
|
||
formatexp = NULL_TREE;
|
||
formatinit = integer_zero_node;
|
||
break;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_end, endinit);
|
||
|
||
if (rec)
|
||
recexp = ffecom_expr (rec_expr);
|
||
else
|
||
recexp = ffecom_integer_zero_node;
|
||
if (TREE_CONSTANT (recexp))
|
||
{
|
||
recinit = recexp;
|
||
recexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
recinit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
ffeste_f2c_init_ (endinit);
|
||
ffeste_f2c_init_ (formatinit);
|
||
ffeste_f2c_init_ (recinit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_cilist_%d", NULL,
|
||
mynumber++),
|
||
f2c_cilist_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (unitfield, unitexp);
|
||
ffeste_f2c_exp_ (formatfield, formatexp);
|
||
ffeste_f2c_exp_ (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;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_cllist_ -- Make arglist with ptr to CLOSE control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_cllist_(...);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_close_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
|
||
unitexp = ffecom_expr (unit_expr);
|
||
if (TREE_CONSTANT (unitexp))
|
||
{
|
||
unitinit = unitexp;
|
||
unitexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitinit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
|
||
ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
ffeste_f2c_init_ (statinit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_cllist_%d", NULL,
|
||
mynumber++),
|
||
f2c_close_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (unitfield, unitexp);
|
||
ffeste_f2c_exp_ (statfield, statexp);
|
||
|
||
ttype = build_pointer_type (TREE_TYPE (t));
|
||
t = ffecom_1 (ADDR_EXPR, ttype, t);
|
||
|
||
t = build_tree_list (NULL_TREE, t);
|
||
|
||
return t;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_icilist_ -- Make arglist with ptr to internal I/O control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_icilist_(...);
|
||
|
||
Returns a tree suitable as an argument list containing a pointer to
|
||
an internal-file 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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_icilist_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
|
||
unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
|
||
if ((ffeinfo_rank (ffebld_info (unit_expr)) == 0)
|
||
|| (TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
|
||
unitnumexp = ffecom_integer_one_node;
|
||
else
|
||
{
|
||
unitnumexp = size_binop (CEIL_DIV_EXPR,
|
||
TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))), unitlenexp);
|
||
unitnumexp = size_binop (CEIL_DIV_EXPR,
|
||
unitnumexp, size_int (TYPE_PRECISION
|
||
(char_type_node)));
|
||
}
|
||
if (TREE_CONSTANT (unitexp))
|
||
{
|
||
unitinit = unitexp;
|
||
unitexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitinit = null_pointer_node;
|
||
constantp = FALSE;
|
||
}
|
||
if ((unitlenexp != NULL_TREE) && TREE_CONSTANT (unitlenexp))
|
||
{
|
||
unitleninit = unitlenexp;
|
||
unitlenexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitleninit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
if (TREE_CONSTANT (unitnumexp))
|
||
{
|
||
unitnuminit = unitnumexp;
|
||
unitnumexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitnuminit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE:
|
||
formatinit = null_pointer_node;
|
||
formatexp = NULL_TREE;
|
||
break;
|
||
|
||
case FFESTV_formatLABEL:
|
||
formatexp = NULL_TREE;
|
||
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_expr (format_spec->u.expr, NULL);
|
||
if (TREE_CONSTANT (formatexp))
|
||
{
|
||
formatinit = formatexp;
|
||
formatexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
formatinit = null_pointer_node;
|
||
constantp = FALSE;
|
||
}
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
formatinit = null_pointer_node;
|
||
formatexp = NULL_TREE;
|
||
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);
|
||
formatexp = NULL_TREE;
|
||
formatinit = ffecom_integer_zero_node;
|
||
break;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_end, endinit);
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
|
||
errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
ffeste_f2c_init_ (endinit);
|
||
ffeste_f2c_init_ (formatinit);
|
||
ffeste_f2c_init_ (unitleninit);
|
||
ffeste_f2c_init_ (unitnuminit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_icilist_%d", NULL,
|
||
mynumber++),
|
||
f2c_icilist_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (unitfield, unitexp);
|
||
ffeste_f2c_exp_ (formatfield, formatexp);
|
||
ffeste_f2c_exp_ (unitlenfield, unitlenexp);
|
||
ffeste_f2c_exp_ (unitnumfield, unitnumexp);
|
||
|
||
ttype = build_pointer_type (TREE_TYPE (t));
|
||
t = ffecom_1 (ADDR_EXPR, ttype, t);
|
||
|
||
t = build_tree_list (NULL_TREE, t);
|
||
|
||
return t;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_impdo_ -- Handle implied-DO in I/O list
|
||
|
||
ffebld expr;
|
||
ffeste_io_impdo_(expr);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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; /* Used for list of items in left part of
|
||
impdo. */
|
||
ffebld item; /* I/O item from head of given list. */
|
||
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;
|
||
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_io_call_ ((*ffeste_io_driver_) (item), TRUE);
|
||
clear_momentary ();
|
||
}
|
||
|
||
/* Generate end of implied-do construct. */
|
||
|
||
ffeste_end_iterdo_ (tvar, tincr, titervar);
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_inlist_ -- Make arglist with ptr to INQUIRE control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_inlist_(...);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_inquire_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
ffeste_f2c_intspec_ (unit_spec, unitexp, unitinit);
|
||
ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
|
||
ffeste_f2c_ptrtointspec_ (exist_spec, existexp, existinit);
|
||
ffeste_f2c_ptrtointspec_ (open_spec, openexp, openinit);
|
||
ffeste_f2c_ptrtointspec_ (number_spec, numberexp, numberinit);
|
||
ffeste_f2c_ptrtointspec_ (named_spec, namedexp, namedinit);
|
||
ffeste_f2c_charspec_ (name_spec, nameexp, nameinit, namelenexp, nameleninit);
|
||
ffeste_f2c_charspec_ (access_spec, accessexp, accessinit, accesslenexp,
|
||
accessleninit);
|
||
ffeste_f2c_charspec_ (sequential_spec, sequentialexp, sequentialinit,
|
||
sequentiallenexp, sequentialleninit);
|
||
ffeste_f2c_charspec_ (direct_spec, directexp, directinit, directlenexp,
|
||
directleninit);
|
||
ffeste_f2c_charspec_ (form_spec, formexp, forminit, formlenexp, formleninit);
|
||
ffeste_f2c_charspec_ (formatted_spec, formattedexp, formattedinit,
|
||
formattedlenexp, formattedleninit);
|
||
ffeste_f2c_charspec_ (unformatted_spec, unformattedexp, unformattedinit,
|
||
unformattedlenexp, unformattedleninit);
|
||
ffeste_f2c_ptrtointspec_ (recl_spec, reclexp, reclinit);
|
||
ffeste_f2c_ptrtointspec_ (nextrec_spec, nextrecexp, nextrecinit);
|
||
ffeste_f2c_charspec_ (blank_spec, blankexp, blankinit, blanklenexp,
|
||
blankleninit);
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
|
||
errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
ffeste_f2c_init_ (fileinit);
|
||
ffeste_f2c_init_ (fileleninit);
|
||
ffeste_f2c_init_ (existinit);
|
||
ffeste_f2c_init_ (openinit);
|
||
ffeste_f2c_init_ (numberinit);
|
||
ffeste_f2c_init_ (namedinit);
|
||
ffeste_f2c_init_ (nameinit);
|
||
ffeste_f2c_init_ (nameleninit);
|
||
ffeste_f2c_init_ (accessinit);
|
||
ffeste_f2c_init_ (accessleninit);
|
||
ffeste_f2c_init_ (sequentialinit);
|
||
ffeste_f2c_init_ (sequentialleninit);
|
||
ffeste_f2c_init_ (directinit);
|
||
ffeste_f2c_init_ (directleninit);
|
||
ffeste_f2c_init_ (forminit);
|
||
ffeste_f2c_init_ (formleninit);
|
||
ffeste_f2c_init_ (formattedinit);
|
||
ffeste_f2c_init_ (formattedleninit);
|
||
ffeste_f2c_init_ (unformattedinit);
|
||
ffeste_f2c_init_ (unformattedleninit);
|
||
ffeste_f2c_init_ (reclinit);
|
||
ffeste_f2c_init_ (nextrecinit);
|
||
ffeste_f2c_init_ (blankinit);
|
||
ffeste_f2c_init_ (blankleninit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_inlist_%d", NULL,
|
||
mynumber++),
|
||
f2c_inquire_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (unitfield, unitexp);
|
||
ffeste_f2c_exp_ (filefield, fileexp);
|
||
ffeste_f2c_exp_ (filelenfield, filelenexp);
|
||
ffeste_f2c_exp_ (existfield, existexp);
|
||
ffeste_f2c_exp_ (openfield, openexp);
|
||
ffeste_f2c_exp_ (numberfield, numberexp);
|
||
ffeste_f2c_exp_ (namedfield, namedexp);
|
||
ffeste_f2c_exp_ (namefield, nameexp);
|
||
ffeste_f2c_exp_ (namelenfield, namelenexp);
|
||
ffeste_f2c_exp_ (accessfield, accessexp);
|
||
ffeste_f2c_exp_ (accesslenfield, accesslenexp);
|
||
ffeste_f2c_exp_ (sequentialfield, sequentialexp);
|
||
ffeste_f2c_exp_ (sequentiallenfield, sequentiallenexp);
|
||
ffeste_f2c_exp_ (directfield, directexp);
|
||
ffeste_f2c_exp_ (directlenfield, directlenexp);
|
||
ffeste_f2c_exp_ (formfield, formexp);
|
||
ffeste_f2c_exp_ (formlenfield, formlenexp);
|
||
ffeste_f2c_exp_ (formattedfield, formattedexp);
|
||
ffeste_f2c_exp_ (formattedlenfield, formattedlenexp);
|
||
ffeste_f2c_exp_ (unformattedfield, unformattedexp);
|
||
ffeste_f2c_exp_ (unformattedlenfield, unformattedlenexp);
|
||
ffeste_f2c_exp_ (reclfield, reclexp);
|
||
ffeste_f2c_exp_ (nextrecfield, nextrecexp);
|
||
ffeste_f2c_exp_ (blankfield, blankexp);
|
||
ffeste_f2c_exp_ (blanklenfield, blanklenexp);
|
||
|
||
ttype = build_pointer_type (TREE_TYPE (t));
|
||
t = ffecom_1 (ADDR_EXPR, ttype, t);
|
||
|
||
t = build_tree_list (NULL_TREE, t);
|
||
|
||
return t;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_io_olist_ -- Make arglist with ptr to OPEN control list
|
||
|
||
tree arglist;
|
||
arglist = ffeste_io_olist_(...);
|
||
|
||
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. */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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;
|
||
int yes;
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
f2c_open_struct = ref;
|
||
}
|
||
|
||
ffeste_f2c_flagspec_ (have_err, errinit);
|
||
|
||
unitexp = ffecom_expr (unit_expr);
|
||
if (TREE_CONSTANT (unitexp))
|
||
{
|
||
unitinit = unitexp;
|
||
unitexp = NULL_TREE;
|
||
}
|
||
else
|
||
{
|
||
unitinit = ffecom_integer_zero_node;
|
||
constantp = FALSE;
|
||
}
|
||
|
||
ffeste_f2c_charspec_ (file_spec, fileexp, fileinit, filelenexp, fileleninit);
|
||
ffeste_f2c_charnolenspec_ (stat_spec, statexp, statinit);
|
||
ffeste_f2c_charnolenspec_ (access_spec, accessexp, accessinit);
|
||
ffeste_f2c_charnolenspec_ (form_spec, formexp, forminit);
|
||
ffeste_f2c_intspec_ (recl_spec, reclexp, reclinit);
|
||
ffeste_f2c_charnolenspec_ (blank_spec, blankexp, blankinit);
|
||
|
||
inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
|
||
initn = inits;
|
||
ffeste_f2c_init_ (unitinit);
|
||
ffeste_f2c_init_ (fileinit);
|
||
ffeste_f2c_init_ (fileleninit);
|
||
ffeste_f2c_init_ (statinit);
|
||
ffeste_f2c_init_ (accessinit);
|
||
ffeste_f2c_init_ (forminit);
|
||
ffeste_f2c_init_ (reclinit);
|
||
ffeste_f2c_init_ (blankinit);
|
||
|
||
inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
|
||
TREE_CONSTANT (inits) = constantp ? 1 : 0;
|
||
TREE_STATIC (inits) = 1;
|
||
|
||
yes = suspend_momentary ();
|
||
|
||
t = build_decl (VAR_DECL,
|
||
ffecom_get_invented_identifier ("__g77_olist_%d", NULL,
|
||
mynumber++),
|
||
f2c_open_struct);
|
||
TREE_STATIC (t) = 1;
|
||
t = ffecom_start_decl (t, 1);
|
||
ffecom_finish_decl (t, inits, 0);
|
||
|
||
resume_momentary (yes);
|
||
|
||
ffeste_f2c_exp_ (unitfield, unitexp);
|
||
ffeste_f2c_exp_ (filefield, fileexp);
|
||
ffeste_f2c_exp_ (filelenfield, filelenexp);
|
||
ffeste_f2c_exp_ (statfield, statexp);
|
||
ffeste_f2c_exp_ (accessfield, accessexp);
|
||
ffeste_f2c_exp_ (formfield, formexp);
|
||
ffeste_f2c_exp_ (reclfield, reclexp);
|
||
ffeste_f2c_exp_ (blankfield, blankexp);
|
||
|
||
ttype = build_pointer_type (TREE_TYPE (t));
|
||
t = ffecom_1 (ADDR_EXPR, ttype, t);
|
||
|
||
t = build_tree_list (NULL_TREE, t);
|
||
|
||
return t;
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_subr_file_ -- Display file-statement specifier
|
||
|
||
ffeste_subr_file_(&specifier); */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
static void
|
||
ffeste_subr_file_ (char *kw, ffestpFile *spec)
|
||
{
|
||
if (!spec->kw_or_val_present)
|
||
return;
|
||
fputs (kw, dmpout);
|
||
if (spec->value_present)
|
||
{
|
||
fputc ('=', dmpout);
|
||
if (spec->value_is_label)
|
||
{
|
||
assert (spec->value_is_label == 2); /* Temporary checking only. */
|
||
fprintf (dmpout, "%" ffelabValue_f "u",
|
||
ffelab_value (spec->u.label));
|
||
}
|
||
else
|
||
ffebld_dump (spec->u.expr);
|
||
}
|
||
fputc (',', dmpout);
|
||
}
|
||
#endif
|
||
|
||
/* ffeste_subr_beru_ -- Generate code for BACKSPACE/ENDFILE/REWIND
|
||
|
||
ffeste_subr_beru_(FFECOM_gfrtFBACK); */
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
static void
|
||
ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
|
||
{
|
||
tree alist;
|
||
bool iostat;
|
||
bool errl;
|
||
|
||
#define specified(something) (info->beru_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
/* Do the real work. */
|
||
|
||
iostat = specified (FFESTP_beruixIOSTAT);
|
||
errl = specified (FFESTP_beruixERR);
|
||
|
||
/* ~~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. */
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
|
||
info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
|
||
|
||
if (errl)
|
||
{ /* ERR= */
|
||
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= */
|
||
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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, or ERR= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!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);
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
#undef specified
|
||
|
||
clear_momentary ();
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_do -- End of statement following DO-term-stmt etc
|
||
|
||
ffeste_do(TRUE);
|
||
|
||
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. These cases invoke this function with ok==TRUE, so
|
||
only forced stack popping (via ffeste_eof_()) invokes it with ok==FALSE. */
|
||
|
||
void
|
||
ffeste_do (ffestw block)
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_DO\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
if (ffestw_do_tvar (block) == 0)
|
||
expand_end_loop (); /* DO WHILE and just DO. */
|
||
else
|
||
ffeste_end_iterdo_ (ffestw_do_tvar (block),
|
||
ffestw_do_incr_saved (block),
|
||
ffestw_do_count_var (block));
|
||
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_end_R807 -- End of statement following logical IF
|
||
|
||
ffeste_end_R807(TRUE);
|
||
|
||
Applies ONLY to logical IF, not to IF-THEN. For example, does not
|
||
ffelex_token_kill the construct name for an IF-THEN block (the name
|
||
field is invalid for logical IF). ok==TRUE iff statement following
|
||
logical IF (substatement) is valid; else, statement is invalid or
|
||
stack forcibly popped due to ffeste_eof_(). */
|
||
|
||
void
|
||
ffeste_end_R807 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
expand_end_cond ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_labeldef_branch -- Generate "code" for branch label def
|
||
|
||
ffeste_labeldef_branch(label); */
|
||
|
||
void
|
||
ffeste_labeldef_branch (ffelab label)
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ label %lu\n", ffelab_value (label));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
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);
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_labeldef_format -- Generate "code" for FORMAT label def
|
||
|
||
ffeste_labeldef_format(label); */
|
||
|
||
void
|
||
ffeste_labeldef_format (ffelab label)
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "$ label %lu\n", ffelab_value (label));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_label_formatdef_ = label;
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R737A -- Assignment statement outside of WHERE
|
||
|
||
ffeste_R737A(dest_expr,source_expr); */
|
||
|
||
void
|
||
ffeste_R737A (ffebld dest, ffebld source)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ let ", dmpout);
|
||
ffebld_dump (dest);
|
||
fputs ("=", dmpout);
|
||
ffebld_dump (source);
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
ffecom_expand_let_stmt (dest, source);
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R803 -- Block IF (IF-THEN) statement
|
||
|
||
ffeste_R803(construct_name,expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. */
|
||
|
||
void
|
||
ffeste_R803 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ IF_block (", dmpout);
|
||
ffebld_dump (expr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R804 -- ELSE IF statement
|
||
|
||
ffeste_R804(expr,expr_token,name_token);
|
||
|
||
Make sure ffeste_kind_ identifies an IF block. If not
|
||
NULL, make sure name_token gives the correct name. Implement the else
|
||
of the IF block. */
|
||
|
||
void
|
||
ffeste_R804 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ ELSE_IF (", dmpout);
|
||
ffebld_dump (expr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
expand_start_elseif (ffecom_truth_value (ffecom_expr (expr)));
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R805 -- ELSE statement
|
||
|
||
ffeste_R805(name_token);
|
||
|
||
Make sure ffeste_kind_ identifies an IF block. If not
|
||
NULL, make sure name_token gives the correct name. Implement the ELSE
|
||
of the IF block. */
|
||
|
||
void
|
||
ffeste_R805 ()
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ ELSE\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
expand_start_else ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R806 -- End an IF-THEN
|
||
|
||
ffeste_R806(TRUE); */
|
||
|
||
void
|
||
ffeste_R806 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_IF_then\n", dmpout); /* Also see ffeste_shriek_if_. */
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
expand_end_cond ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R807 -- Logical IF statement
|
||
|
||
ffeste_R807(expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. */
|
||
|
||
void
|
||
ffeste_R807 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ IF_logical (", dmpout);
|
||
ffebld_dump (expr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
expand_start_cond (ffecom_truth_value (ffecom_expr (expr)), 0);
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R809 -- SELECT CASE statement
|
||
|
||
ffeste_R809(construct_name,expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. */
|
||
|
||
void
|
||
ffeste_R809 (ffestw block, ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ SELECT_CASE (", dmpout);
|
||
ffebld_dump (expr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffecom_push_calltemps ();
|
||
|
||
{
|
||
tree texpr;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
if ((expr == NULL)
|
||
|| (ffeinfo_basictype (ffebld_info (expr))
|
||
== FFEINFO_basictypeANY))
|
||
{
|
||
ffestw_set_select_texpr (block, error_mark_node);
|
||
clear_momentary ();
|
||
}
|
||
else
|
||
{
|
||
texpr = ffecom_expr (expr);
|
||
if (ffeinfo_basictype (ffebld_info (expr))
|
||
!= FFEINFO_basictypeCHARACTER)
|
||
{
|
||
expand_start_case (1, texpr, TREE_TYPE (texpr),
|
||
"SELECT CASE statement");
|
||
ffestw_set_select_texpr (block, texpr);
|
||
ffestw_set_select_break (block, FALSE);
|
||
push_momentary ();
|
||
}
|
||
else
|
||
{
|
||
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);
|
||
}
|
||
}
|
||
}
|
||
|
||
ffecom_pop_calltemps ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R810 -- CASE statement
|
||
|
||
ffeste_R810(case_value_range_list,name);
|
||
|
||
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;
|
||
|
||
ffeste_check_simple_ ();
|
||
|
||
if (s->first_stmt == (ffestwCase) &s->first_rel)
|
||
c = NULL;
|
||
else
|
||
c = s->first_stmt;
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if ((c == NULL) || (casenum != c->casenum))
|
||
{
|
||
if (casenum == 0) /* Intentional CASE DEFAULT. */
|
||
fputs ("+ CASE_DEFAULT", dmpout);
|
||
}
|
||
else
|
||
{
|
||
bool comma = FALSE;
|
||
|
||
fputs ("+ CASE (", dmpout);
|
||
do
|
||
{
|
||
if (comma)
|
||
fputc (',', dmpout);
|
||
else
|
||
comma = TRUE;
|
||
if (c->low != NULL)
|
||
ffebld_constant_dump (c->low);
|
||
if (c->low != c->high)
|
||
{
|
||
fputc (':', dmpout);
|
||
if (c->high != NULL)
|
||
ffebld_constant_dump (c->high);
|
||
}
|
||
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));
|
||
fputc (')', dmpout);
|
||
}
|
||
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree texprlow;
|
||
tree texprhigh;
|
||
tree tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
|
||
int pushok;
|
||
tree duplicate;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
|
||
{
|
||
clear_momentary ();
|
||
return;
|
||
}
|
||
|
||
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));
|
||
|
||
clear_momentary ();
|
||
} /* ~~~handle character, character*1 */
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R811 -- End a SELECT
|
||
|
||
ffeste_R811(TRUE); */
|
||
|
||
void
|
||
ffeste_R811 (ffestw block)
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_SELECT\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
|
||
if (TREE_CODE (ffestw_select_texpr (block)) == ERROR_MARK)
|
||
{
|
||
clear_momentary ();
|
||
return;
|
||
}
|
||
|
||
expand_end_case (ffestw_select_texpr (block));
|
||
pop_momentary ();
|
||
clear_momentary (); /* ~~~handle character and character*1 */
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* 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_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if ((ffebld_op (incr) == FFEBLD_opCONTER)
|
||
&& (ffebld_constant_is_zero (ffebld_conter (incr))))
|
||
{
|
||
ffebad_start (FFEBAD_DO_STEP_ZERO);
|
||
ffebad_here (0, ffelex_token_where_line (incr_token),
|
||
ffelex_token_where_column (incr_token));
|
||
ffebad_string ("Iterative DO loop");
|
||
ffebad_finish ();
|
||
/* Don't bother replacing it with 1 yet. */
|
||
}
|
||
|
||
if (label == NULL)
|
||
fputs ("+ DO_iterative_nonlabeled (", dmpout);
|
||
else
|
||
fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label));
|
||
ffebld_dump (var);
|
||
fputc ('=', dmpout);
|
||
ffebld_dump (start);
|
||
fputc (',', dmpout);
|
||
ffebld_dump (end);
|
||
fputc (',', dmpout);
|
||
ffebld_dump (incr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
/* Start the DO loop. */
|
||
|
||
ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
|
||
var,
|
||
start, start_token,
|
||
end, end_token,
|
||
incr, incr_token,
|
||
"Iterative DO loop");
|
||
|
||
ffecom_pop_calltemps ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R819B -- DO WHILE statement
|
||
|
||
ffeste_R819B(construct_name,label_token,expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. */
|
||
|
||
void
|
||
ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if (label == NULL)
|
||
fputs ("+ DO_WHILE_nonlabeled (", dmpout);
|
||
else
|
||
fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label));
|
||
ffebld_dump (expr);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
ffestw_set_do_hook (block, expand_start_loop (1));
|
||
ffestw_set_do_tvar (block, 0); /* Means DO WHILE vs. iter DO. */
|
||
if (expr != NULL)
|
||
expand_exit_loop_if_false (0, ffecom_truth_value (ffecom_expr (expr)));
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R825 -- END DO statement
|
||
|
||
ffeste_R825(name_token);
|
||
|
||
Make sure ffeste_kind_ identifies a DO block. If not
|
||
NULL, make sure name_token gives the correct name. Do whatever
|
||
is specific to seeing END DO with a DO-target label definition on it,
|
||
where the END DO is really treated as a CONTINUE (i.e. generate th
|
||
same code you would for CONTINUE). ffeste_do handles the actual
|
||
generation of end-loop code. */
|
||
|
||
void
|
||
ffeste_R825 ()
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_DO_sugar\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
emit_nop ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R834 -- CYCLE statement
|
||
|
||
ffeste_R834(name_token);
|
||
|
||
Handle a CYCLE within a loop. */
|
||
|
||
void
|
||
ffeste_R834 (ffestw block)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
expand_continue_loop (ffestw_do_hook (block));
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R835 -- EXIT statement
|
||
|
||
ffeste_R835(name_token);
|
||
|
||
Handle a EXIT within a loop. */
|
||
|
||
void
|
||
ffeste_R835 (ffestw block)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
expand_exit_loop (ffestw_do_hook (block));
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R836 -- GOTO statement
|
||
|
||
ffeste_R836(label);
|
||
|
||
Make sure label_token identifies a valid label for a GOTO. Update
|
||
that label's info to indicate it is the target of a GOTO. */
|
||
|
||
void
|
||
ffeste_R836 (ffelab label)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree glabel;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
glabel = ffecom_lookup_label (label);
|
||
if ((glabel != NULL_TREE)
|
||
&& (TREE_CODE (glabel) != ERROR_MARK))
|
||
{
|
||
TREE_USED (glabel) = 1;
|
||
expand_goto (glabel);
|
||
clear_momentary ();
|
||
}
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R837 -- Computed GOTO statement
|
||
|
||
ffeste_R837(labels,count,expr);
|
||
|
||
Make sure label_list identifies valid labels for a GOTO. Update
|
||
each label's info to indicate it is the target of a GOTO. */
|
||
|
||
void
|
||
ffeste_R837 (ffelab *labels, int count, ffebld expr)
|
||
{
|
||
int i;
|
||
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ CGOTO (", dmpout);
|
||
for (i = 0; i < count; ++i)
|
||
{
|
||
if (i != 0)
|
||
fputc (',', dmpout);
|
||
fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
|
||
}
|
||
fputs ("),", dmpout);
|
||
ffebld_dump (expr);
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree texpr;
|
||
tree value;
|
||
tree tlabel;
|
||
int pushok;
|
||
tree duplicate;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
texpr = ffecom_expr (expr);
|
||
expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
|
||
push_momentary (); /* In case of lots of labels, keep clearing
|
||
them out. */
|
||
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;
|
||
TREE_USED (tlabel) = 1;
|
||
expand_goto (tlabel);
|
||
clear_momentary ();
|
||
}
|
||
pop_momentary ();
|
||
expand_end_case (texpr);
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R838 -- ASSIGN statement
|
||
|
||
ffeste_R838(label_token,target_variable,target_token);
|
||
|
||
Make sure label_token identifies a valid label for an assignment. Update
|
||
that label's info to indicate it is the source of an assignment. Update
|
||
target_variable's info to indicate it is the target the assignment of that
|
||
label. */
|
||
|
||
void
|
||
ffeste_R838 (ffelab label, ffebld target)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label));
|
||
ffebld_dump (target);
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree expr_tree;
|
||
tree label_tree;
|
||
tree target_tree;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
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);
|
||
clear_momentary ();
|
||
}
|
||
|
||
ffecom_pop_calltemps ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R839 -- Assigned GOTO statement
|
||
|
||
ffeste_R839(target,target_token,label_list);
|
||
|
||
Make sure label_list identifies valid labels for a GOTO. Update
|
||
each label's info to indicate it is the target of a GOTO. */
|
||
|
||
void
|
||
ffeste_R839 (ffebld target)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ AGOTO ", dmpout);
|
||
ffebld_dump (target);
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree t;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
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));
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R840 -- Arithmetic IF statement
|
||
|
||
ffeste_R840(expr,expr_token,neg,zero,pos);
|
||
|
||
Make sure the labels are valid; implement. */
|
||
|
||
void
|
||
ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ IF_arithmetic (", dmpout);
|
||
ffebld_dump (expr);
|
||
fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
|
||
ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree gneg = ffecom_lookup_label (neg);
|
||
tree gzero = ffecom_lookup_label (zero);
|
||
tree gpos = ffecom_lookup_label (pos);
|
||
tree texpr;
|
||
|
||
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;
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
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_emit_line_note_ ();
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R841 -- CONTINUE statement
|
||
|
||
ffeste_R841(); */
|
||
|
||
void
|
||
ffeste_R841 ()
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ CONTINUE\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_emit_line_note_ ();
|
||
emit_nop ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R842 -- STOP statement
|
||
|
||
ffeste_R842(expr); */
|
||
|
||
void
|
||
ffeste_R842 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if (expr == NULL)
|
||
{
|
||
fputs ("+ STOP\n", dmpout);
|
||
}
|
||
else
|
||
{
|
||
fputs ("+ STOP_coded ", dmpout);
|
||
ffebld_dump (expr);
|
||
fputc ('\n', dmpout);
|
||
}
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree callit;
|
||
ffelexToken msg;
|
||
|
||
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);
|
||
}
|
||
|
||
ffecom_push_calltemps ();
|
||
callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
|
||
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
|
||
ffecom_pop_calltemps ();
|
||
TREE_SIDE_EFFECTS (callit) = 1;
|
||
expand_expr_stmt (callit);
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R843 -- PAUSE statement
|
||
|
||
ffeste_R843(expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. expr and expr_token are
|
||
both NULL if there was no expression. */
|
||
|
||
void
|
||
ffeste_R843 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if (expr == NULL)
|
||
{
|
||
fputs ("+ PAUSE\n", dmpout);
|
||
}
|
||
else
|
||
{
|
||
fputs ("+ PAUSE_coded ", dmpout);
|
||
ffebld_dump (expr);
|
||
fputc ('\n', dmpout);
|
||
}
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree callit;
|
||
ffelexToken msg;
|
||
|
||
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);
|
||
}
|
||
|
||
ffecom_push_calltemps ();
|
||
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
|
||
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
|
||
ffecom_pop_calltemps ();
|
||
TREE_SIDE_EFFECTS (callit) = 1;
|
||
expand_expr_stmt (callit);
|
||
clear_momentary ();
|
||
}
|
||
#if 0 /* Old approach for phantom g77 run-time
|
||
library. */
|
||
{
|
||
tree callit;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
if (expr == NULL)
|
||
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE);
|
||
else if (ffeinfo_basictype (ffebld_info (expr))
|
||
== FFEINFO_basictypeINTEGER)
|
||
{
|
||
ffecom_push_calltemps ();
|
||
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
|
||
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
|
||
ffecom_pop_calltemps ();
|
||
}
|
||
else
|
||
{
|
||
if (ffeinfo_basictype (ffebld_info (expr))
|
||
!= FFEINFO_basictypeCHARACTER)
|
||
break;
|
||
ffecom_push_calltemps ();
|
||
callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
|
||
ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)));
|
||
ffecom_pop_calltemps ();
|
||
}
|
||
TREE_SIDE_EFFECTS (callit) = 1;
|
||
expand_expr_stmt (callit);
|
||
clear_momentary ();
|
||
}
|
||
#endif
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R904 -- OPEN statement
|
||
|
||
ffeste_R904();
|
||
|
||
Make sure an OPEN is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R904 (ffestpOpenStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ OPEN (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
|
||
ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
|
||
ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
|
||
ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
|
||
ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
|
||
ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
|
||
ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
|
||
ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
|
||
ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
|
||
ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
|
||
ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
|
||
ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
|
||
ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
|
||
ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
|
||
ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
|
||
ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
|
||
ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
|
||
ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
|
||
ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
|
||
ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
|
||
ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
|
||
ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
|
||
ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
|
||
ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
|
||
ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
|
||
ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
|
||
ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
|
||
ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree args;
|
||
bool iostat;
|
||
bool errl;
|
||
|
||
#define specified(something) (info->open_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
iostat = specified (FFESTP_openixIOSTAT);
|
||
errl = specified (FFESTP_openixERR);
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
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]);
|
||
|
||
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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->open_spec[FFESTP_openixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, or ERR= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!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);
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
#undef specified
|
||
}
|
||
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R907 -- CLOSE statement
|
||
|
||
ffeste_R907();
|
||
|
||
Make sure a CLOSE is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R907 (ffestpCloseStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ CLOSE (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
|
||
ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
|
||
ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree args;
|
||
bool iostat;
|
||
bool errl;
|
||
|
||
#define specified(something) (info->close_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
iostat = specified (FFESTP_closeixIOSTAT);
|
||
errl = specified (FFESTP_closeixERR);
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
args = ffeste_io_cllist_ (errl || iostat,
|
||
info->close_spec[FFESTP_closeixUNIT].u.expr,
|
||
&info->close_spec[FFESTP_closeixSTATUS]);
|
||
|
||
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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->close_spec[FFESTP_closeixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, or ERR= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!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);
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
#undef specified
|
||
}
|
||
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R909_start -- READ(...) statement list begin
|
||
|
||
ffeste_R909_start(FALSE);
|
||
|
||
Verify that READ is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
|
||
ffestvUnit unit, ffestvFormat format, bool rec,
|
||
bool key UNUSED)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE:
|
||
if (rec)
|
||
fputs ("+ READ_ufdac", dmpout);
|
||
else if (key)
|
||
fputs ("+ READ_ufidx", dmpout);
|
||
else
|
||
fputs ("+ READ_ufseq", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
if (rec)
|
||
fputs ("+ READ_fmdac", dmpout);
|
||
else if (key)
|
||
fputs ("+ READ_fmidx", dmpout);
|
||
else if (unit == FFESTV_unitCHAREXPR)
|
||
fputs ("+ READ_fmint", dmpout);
|
||
else
|
||
fputs ("+ READ_fmseq", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
if (unit == FFESTV_unitCHAREXPR)
|
||
fputs ("+ READ_lsint", dmpout);
|
||
else
|
||
fputs ("+ READ_lsseq", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatNAMELIST:
|
||
fputs ("+ READ_nlseq", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in R909 READ" == NULL);
|
||
}
|
||
|
||
if (only_format)
|
||
{
|
||
fputc (' ', dmpout);
|
||
ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
|
||
fputc (' ', dmpout);
|
||
|
||
return;
|
||
}
|
||
|
||
fputs (" (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
|
||
ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
|
||
ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
|
||
ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
|
||
ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
|
||
ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
|
||
ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
|
||
ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
|
||
ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
|
||
ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
|
||
ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
|
||
ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
|
||
ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
|
||
#define specified(something) (info->read_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
/* Do the real work. */
|
||
|
||
{
|
||
ffecomGfrt start;
|
||
ffecomGfrt end;
|
||
tree cilist;
|
||
bool iostat;
|
||
bool errl;
|
||
bool endl;
|
||
|
||
/* First determine the start, per-item, and end run-time functions to
|
||
call. The per-item function is picked by choosing an ffeste functio
|
||
to call to handle a given item; it knows how to generate a call to the
|
||
appropriate run-time function, and is called an "io driver". It
|
||
handles the implied-DO construct, for example. */
|
||
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE: /* no FMT= */
|
||
ffeste_io_driver_ = ffeste_io_douio_;
|
||
if (rec)
|
||
start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
|
||
#if 0
|
||
else if (key)
|
||
start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
|
||
#endif
|
||
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;
|
||
#if 0
|
||
else if (key)
|
||
start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
|
||
#endif
|
||
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;
|
||
|
||
iostat = specified (FFESTP_readixIOSTAT);
|
||
errl = specified (FFESTP_readixERR);
|
||
endl = specified (FFESTP_readixEND);
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
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 (errl)
|
||
{ /* ERR= */
|
||
ffeste_io_err_
|
||
= ffecom_lookup_label
|
||
(info->read_spec[FFESTP_readixERR].u.label);
|
||
|
||
if (endl)
|
||
{ /* ERR= END= */
|
||
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
|
||
{ /* 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= */
|
||
ffeste_io_err_ = NULL_TREE;
|
||
if (endl)
|
||
{ /* 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
|
||
{ /* 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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->read_spec[FFESTP_readixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= or END= or both */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, ERR=, or END= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
|
||
}
|
||
|
||
#undef specified
|
||
|
||
push_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R909_item -- READ statement i/o item
|
||
|
||
ffeste_R909_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_R909_item (ffebld expr, ffelexToken expr_token)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
if (expr == NULL)
|
||
return;
|
||
while (ffebld_op (expr) == FFEBLD_opPAREN)
|
||
expr = ffebld_left (expr); /* "READ *,(A)" -- really a bug in the user's
|
||
code, but I've been told lots of code does
|
||
this (blech)! */
|
||
if (ffebld_op (expr) == FFEBLD_opANY)
|
||
return;
|
||
if (ffebld_op (expr) == FFEBLD_opIMPDO)
|
||
ffeste_io_impdo_ (expr, expr_token);
|
||
else
|
||
ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R909_finish -- READ statement list complete
|
||
|
||
ffeste_R909_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_R909_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
|
||
/* 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),
|
||
!ffeste_io_abort_is_temp_);
|
||
|
||
clear_momentary ();
|
||
pop_momentary ();
|
||
|
||
/* 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 ();
|
||
}
|
||
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R910_start -- WRITE(...) statement list begin
|
||
|
||
ffeste_R910_start();
|
||
|
||
Verify that WRITE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
|
||
ffestvFormat format, bool rec)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE:
|
||
if (rec)
|
||
fputs ("+ WRITE_ufdac (", dmpout);
|
||
else
|
||
fputs ("+ WRITE_ufseq_or_idx (", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
if (rec)
|
||
fputs ("+ WRITE_fmdac (", dmpout);
|
||
else if (unit == FFESTV_unitCHAREXPR)
|
||
fputs ("+ WRITE_fmint (", dmpout);
|
||
else
|
||
fputs ("+ WRITE_fmseq_or_idx (", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
if (unit == FFESTV_unitCHAREXPR)
|
||
fputs ("+ WRITE_lsint (", dmpout);
|
||
else
|
||
fputs ("+ WRITE_lsseq (", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatNAMELIST:
|
||
fputs ("+ WRITE_nlseq (", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in R910 WRITE" == NULL);
|
||
}
|
||
|
||
ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
|
||
ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
|
||
ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
|
||
ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
|
||
ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
|
||
ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
|
||
#define specified(something) (info->write_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
/* Do the real work. */
|
||
|
||
{
|
||
ffecomGfrt start;
|
||
ffecomGfrt end;
|
||
tree cilist;
|
||
bool iostat;
|
||
bool errl;
|
||
|
||
/* First determine the start, per-item, and end run-time functions to
|
||
call. The per-item function is picked by choosing an ffeste functio
|
||
to call to handle a given item; it knows how to generate a call to the
|
||
appropriate run-time function, and is called an "io driver". It
|
||
handles the implied-DO construct, for example. */
|
||
|
||
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;
|
||
|
||
iostat = specified (FFESTP_writeixIOSTAT);
|
||
errl = specified (FFESTP_writeixERR);
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
if (unit == FFESTV_unitCHAREXPR)
|
||
{
|
||
cilist = ffeste_io_icilist_ (errl || iostat,
|
||
info->write_spec[FFESTP_writeixUNIT].u.expr,
|
||
FALSE, format,
|
||
&info->write_spec[FFESTP_writeixFORMAT]);
|
||
}
|
||
else
|
||
{
|
||
cilist = ffeste_io_cilist_ (errl || iostat, unit,
|
||
info->write_spec[FFESTP_writeixUNIT].u.expr,
|
||
6, FALSE, format,
|
||
&info->write_spec[FFESTP_writeixFORMAT],
|
||
rec,
|
||
info->write_spec[FFESTP_writeixREC].u.expr);
|
||
}
|
||
|
||
ffeste_io_end_ = NULL_TREE;
|
||
|
||
if (errl)
|
||
{ /* ERR= */
|
||
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= */
|
||
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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->write_spec[FFESTP_writeixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, or ERR= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
|
||
}
|
||
|
||
#undef specified
|
||
|
||
push_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R910_item -- WRITE statement i/o item
|
||
|
||
ffeste_R910_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_R910_item (ffebld expr, ffelexToken expr_token)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R910_finish -- WRITE statement list complete
|
||
|
||
ffeste_R910_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_R910_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
|
||
/* 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),
|
||
!ffeste_io_abort_is_temp_);
|
||
|
||
clear_momentary ();
|
||
pop_momentary ();
|
||
|
||
/* 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);
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R911_start -- PRINT statement list begin
|
||
|
||
ffeste_R911_start();
|
||
|
||
Verify that PRINT is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
fputs ("+ PRINT_fm ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
fputs ("+ PRINT_ls ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatNAMELIST:
|
||
fputs ("+ PRINT_nl ", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in R911 PRINT" == NULL);
|
||
}
|
||
ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
|
||
fputc (' ', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
/* Do the real work. */
|
||
|
||
{
|
||
ffecomGfrt start;
|
||
ffecomGfrt end;
|
||
tree cilist;
|
||
|
||
/* First determine the start, per-item, and end run-time functions to
|
||
call. The per-item function is picked by choosing an ffeste functio
|
||
to call to handle a given item; it knows how to generate a call to the
|
||
appropriate run-time function, and is called an "io driver". It
|
||
handles the implied-DO construct, for example. */
|
||
|
||
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;
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
|
||
&info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
|
||
|
||
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;
|
||
|
||
/* 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),
|
||
!ffeste_io_abort_is_temp_ || (end != FFECOM_gfrt));
|
||
}
|
||
|
||
push_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R911_item -- PRINT statement i/o item
|
||
|
||
ffeste_R911_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_R911_item (ffebld expr, ffelexToken expr_token)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
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_io_call_ ((*ffeste_io_driver_) (expr), FALSE);
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R911_finish -- PRINT statement list complete
|
||
|
||
ffeste_R911_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_R911_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
if (ffeste_io_endgfrt_ != FFECOM_gfrt)
|
||
ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE),
|
||
FALSE);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
clear_momentary ();
|
||
pop_momentary ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R919 -- BACKSPACE statement
|
||
|
||
ffeste_R919();
|
||
|
||
Make sure a BACKSPACE is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R919 (ffestpBeruStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ BACKSPACE (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
|
||
ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R920 -- ENDFILE statement
|
||
|
||
ffeste_R920();
|
||
|
||
Make sure a ENDFILE is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R920 (ffestpBeruStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ ENDFILE (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
|
||
ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R921 -- REWIND statement
|
||
|
||
ffeste_R921();
|
||
|
||
Make sure a REWIND is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R921 (ffestpBeruStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ REWIND (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
|
||
ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R923A -- INQUIRE statement (non-IOLENGTH version)
|
||
|
||
ffeste_R923A(bool by_file);
|
||
|
||
Make sure an INQUIRE is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if (by_file)
|
||
{
|
||
fputs ("+ INQUIRE_file (", dmpout);
|
||
ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
|
||
}
|
||
else
|
||
{
|
||
fputs ("+ INQUIRE_unit (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
|
||
}
|
||
ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
|
||
ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
|
||
ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
|
||
ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
|
||
ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
|
||
ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
|
||
ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
|
||
ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
|
||
ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
|
||
ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
|
||
ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
|
||
ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
|
||
ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
|
||
ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
|
||
ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
|
||
ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
|
||
ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
|
||
ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
|
||
ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
|
||
ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
|
||
ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
|
||
ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
|
||
ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
|
||
ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
|
||
ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
|
||
ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
|
||
ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree args;
|
||
bool iostat;
|
||
bool errl;
|
||
|
||
#define specified(something) (info->inquire_spec[something].kw_or_val_present)
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
iostat = specified (FFESTP_inquireixIOSTAT);
|
||
errl = specified (FFESTP_inquireixERR);
|
||
|
||
ffecom_push_calltemps ();
|
||
|
||
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]);
|
||
|
||
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)
|
||
{ /* IOSTAT= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = ffecom_expr
|
||
(info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
|
||
}
|
||
else if (ffeste_io_abort_ != NULL_TREE)
|
||
{ /* no IOSTAT= but ERR= */
|
||
ffeste_io_iostat_is_temp_ = TRUE;
|
||
ffeste_io_iostat_
|
||
= ffecom_push_tempvar (ffecom_integer_type_node,
|
||
FFETARGET_charactersizeNONE, -1, FALSE);
|
||
}
|
||
else
|
||
{ /* no IOSTAT=, or ERR= */
|
||
ffeste_io_iostat_is_temp_ = FALSE;
|
||
ffeste_io_iostat_ = NULL_TREE;
|
||
}
|
||
|
||
/* 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),
|
||
!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);
|
||
}
|
||
|
||
/* If we've got a temp iostat, pop the temp. */
|
||
|
||
if (ffeste_io_iostat_is_temp_)
|
||
ffecom_pop_tempvar (ffeste_io_iostat_);
|
||
|
||
ffecom_pop_calltemps ();
|
||
|
||
#undef specified
|
||
}
|
||
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
|
||
|
||
ffeste_R923B_start();
|
||
|
||
Verify that INQUIRE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ INQUIRE (", dmpout);
|
||
ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
|
||
ffeste_emit_line_note_ ();
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R923B_item -- INQUIRE statement i/o item
|
||
|
||
ffeste_R923B_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_R923B_item (ffebld expr UNUSED)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R923B_finish -- INQUIRE statement list complete
|
||
|
||
ffeste_R923B_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_R923B_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
clear_momentary ();
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1001 -- FORMAT statement
|
||
|
||
ffeste_R1001(format_list); */
|
||
|
||
void
|
||
ffeste_R1001 (ffests s)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree t;
|
||
tree ttype;
|
||
tree maxindex;
|
||
tree var;
|
||
|
||
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;
|
||
|
||
push_obstacks_nochange ();
|
||
end_temporary_allocation ();
|
||
|
||
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);
|
||
}
|
||
|
||
resume_temporary_allocation ();
|
||
pop_obstacks ();
|
||
|
||
ffeste_label_formatdef_ = NULL;
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1103 -- End a PROGRAM
|
||
|
||
ffeste_R1103(); */
|
||
|
||
void
|
||
ffeste_R1103 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_PROGRAM\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1112 -- End a BLOCK DATA
|
||
|
||
ffeste_R1112(TRUE); */
|
||
|
||
void
|
||
ffeste_R1112 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("* END_BLOCK_DATA\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1212 -- CALL statement
|
||
|
||
ffeste_R1212(expr,expr_token);
|
||
|
||
Make sure statement is valid here; implement. */
|
||
|
||
void
|
||
ffeste_R1212 (ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ CALL ", dmpout);
|
||
ffebld_dump (expr);
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
ffebld args = ffebld_right (expr);
|
||
ffebld arg;
|
||
ffebld labels = NULL; /* First in list of LABTERs. */
|
||
ffebld prevlabels = NULL;
|
||
ffebld prevargs = NULL;
|
||
|
||
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);
|
||
|
||
if (labels == NULL)
|
||
expand_expr_stmt (ffecom_expr (expr));
|
||
else
|
||
{
|
||
tree texpr;
|
||
tree value;
|
||
tree tlabel;
|
||
int caseno;
|
||
int pushok;
|
||
tree duplicate;
|
||
|
||
texpr = ffecom_expr (expr);
|
||
expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
|
||
push_momentary (); /* In case of many labels, keep 'em cleared
|
||
out. */
|
||
for (caseno = 1;
|
||
labels != NULL;
|
||
++caseno, labels = ffebld_trail (labels))
|
||
{
|
||
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 (labels)));
|
||
if ((tlabel == NULL_TREE)
|
||
|| (TREE_CODE (tlabel) == ERROR_MARK))
|
||
continue;
|
||
TREE_USED (tlabel) = 1;
|
||
expand_goto (tlabel);
|
||
clear_momentary ();
|
||
}
|
||
|
||
pop_momentary ();
|
||
expand_end_case (texpr);
|
||
}
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1221 -- End a FUNCTION
|
||
|
||
ffeste_R1221(TRUE); */
|
||
|
||
void
|
||
ffeste_R1221 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ END_FUNCTION\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1225 -- End a SUBROUTINE
|
||
|
||
ffeste_R1225(TRUE); */
|
||
|
||
void
|
||
ffeste_R1225 ()
|
||
{
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ END_SUBROUTINE\n");
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1226 -- ENTRY statement
|
||
|
||
ffeste_R1226(entryname,arglist,ending_token);
|
||
|
||
Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
|
||
entry point name, and so on. */
|
||
|
||
void
|
||
ffeste_R1226 (ffesymbol entry)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry));
|
||
if (ffesymbol_dummyargs (entry) != NULL)
|
||
{
|
||
ffebld argh;
|
||
|
||
fputc ('(', dmpout);
|
||
for (argh = ffesymbol_dummyargs (entry);
|
||
argh != NULL;
|
||
argh = ffebld_trail (argh))
|
||
{
|
||
assert (ffebld_head (argh) != NULL);
|
||
switch (ffebld_op (ffebld_head (argh)))
|
||
{
|
||
case FFEBLD_opSYMTER:
|
||
fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
|
||
dmpout);
|
||
break;
|
||
|
||
case FFEBLD_opSTAR:
|
||
fputc ('*', dmpout);
|
||
break;
|
||
|
||
default:
|
||
fputc ('?', dmpout);
|
||
ffebld_dump (ffebld_head (argh));
|
||
fputc ('?', dmpout);
|
||
break;
|
||
}
|
||
if (ffebld_trail (argh) != NULL)
|
||
fputc (',', dmpout);
|
||
}
|
||
fputc (')', dmpout);
|
||
}
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree label = ffesymbol_hook (entry).length_tree;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
|
||
DECL_INITIAL (label) = error_mark_node;
|
||
emit_nop ();
|
||
expand_label (label);
|
||
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_R1227 -- RETURN statement
|
||
|
||
ffeste_R1227(expr);
|
||
|
||
Make sure statement is valid here; implement. expr and expr_token are
|
||
both NULL if there was no expression. */
|
||
|
||
void
|
||
ffeste_R1227 (ffestw block UNUSED, ffebld expr)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
if (expr == NULL)
|
||
{
|
||
fputs ("+ RETURN\n", dmpout);
|
||
}
|
||
else
|
||
{
|
||
fputs ("+ RETURN_alternate ", dmpout);
|
||
ffebld_dump (expr);
|
||
fputc ('\n', dmpout);
|
||
}
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
{
|
||
tree rtn;
|
||
|
||
ffeste_emit_line_note_ ();
|
||
ffecom_push_calltemps ();
|
||
|
||
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 ();
|
||
}
|
||
|
||
ffecom_pop_calltemps ();
|
||
clear_momentary ();
|
||
}
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V018_start -- REWRITE(...) statement list begin
|
||
|
||
ffeste_V018_start();
|
||
|
||
Verify that REWRITE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
#if FFESTR_VXT
|
||
void
|
||
ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatNONE:
|
||
fputs ("+ REWRITE_uf (", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
fputs ("+ REWRITE_fm (", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
|
||
}
|
||
ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
|
||
ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
|
||
ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V018_item -- REWRITE statement i/o item
|
||
|
||
ffeste_V018_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_V018_item (ffebld expr)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V018_finish -- REWRITE statement list complete
|
||
|
||
ffeste_V018_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V018_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V019_start -- ACCEPT statement list begin
|
||
|
||
ffeste_V019_start();
|
||
|
||
Verify that ACCEPT is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
fputs ("+ ACCEPT_fm ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
fputs ("+ ACCEPT_ls ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatNAMELIST:
|
||
fputs ("+ ACCEPT_nl ", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
|
||
}
|
||
ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
|
||
fputc (' ', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V019_item -- ACCEPT statement i/o item
|
||
|
||
ffeste_V019_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_V019_item (ffebld expr)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V019_finish -- ACCEPT statement list complete
|
||
|
||
ffeste_V019_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V019_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
#endif
|
||
/* ffeste_V020_start -- TYPE statement list begin
|
||
|
||
ffeste_V020_start();
|
||
|
||
Verify that TYPE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_V020_start (ffestpTypeStmt *info UNUSED,
|
||
ffestvFormat format UNUSED)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
switch (format)
|
||
{
|
||
case FFESTV_formatLABEL:
|
||
case FFESTV_formatCHAREXPR:
|
||
case FFESTV_formatINTEXPR:
|
||
fputs ("+ TYPE_fm ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatASTERISK:
|
||
fputs ("+ TYPE_ls ", dmpout);
|
||
break;
|
||
|
||
case FFESTV_formatNAMELIST:
|
||
fputs ("* TYPE_nl ", dmpout);
|
||
break;
|
||
|
||
default:
|
||
assert ("Unexpected kind of format item in V020 TYPE" == NULL);
|
||
}
|
||
ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
|
||
fputc (' ', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V020_item -- TYPE statement i/o item
|
||
|
||
ffeste_V020_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_V020_item (ffebld expr UNUSED)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V020_finish -- TYPE statement list complete
|
||
|
||
ffeste_V020_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V020_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V021 -- DELETE statement
|
||
|
||
ffeste_V021();
|
||
|
||
Make sure a DELETE is valid in the current context, and implement it. */
|
||
|
||
#if FFESTR_VXT
|
||
void
|
||
ffeste_V021 (ffestpDeleteStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ DELETE (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
|
||
ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
|
||
ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V022 -- UNLOCK statement
|
||
|
||
ffeste_V022();
|
||
|
||
Make sure a UNLOCK is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_V022 (ffestpBeruStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ UNLOCK (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
|
||
ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V023_start -- ENCODE(...) statement list begin
|
||
|
||
ffeste_V023_start();
|
||
|
||
Verify that ENCODE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_V023_start (ffestpVxtcodeStmt *info)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ ENCODE (", dmpout);
|
||
ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
|
||
ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
|
||
ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
|
||
ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V023_item -- ENCODE statement i/o item
|
||
|
||
ffeste_V023_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_V023_item (ffebld expr)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V023_finish -- ENCODE statement list complete
|
||
|
||
ffeste_V023_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V023_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V024_start -- DECODE(...) statement list begin
|
||
|
||
ffeste_V024_start();
|
||
|
||
Verify that DECODE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_V024_start (ffestpVxtcodeStmt *info)
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ DECODE (", dmpout);
|
||
ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
|
||
ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
|
||
ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
|
||
ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
|
||
fputs (") ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V024_item -- DECODE statement i/o item
|
||
|
||
ffeste_V024_item(expr,expr_token);
|
||
|
||
Implement output-list expression. */
|
||
|
||
void
|
||
ffeste_V024_item (ffebld expr)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (expr);
|
||
fputc (',', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V024_finish -- DECODE statement list complete
|
||
|
||
ffeste_V024_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V024_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V025_start -- DEFINEFILE statement list begin
|
||
|
||
ffeste_V025_start();
|
||
|
||
Verify that DEFINEFILE is valid here, and begin accepting items in the
|
||
list. */
|
||
|
||
void
|
||
ffeste_V025_start ()
|
||
{
|
||
ffeste_check_start_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ DEFINE_FILE ", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V025_item -- DEFINE FILE statement item
|
||
|
||
ffeste_V025_item(u,ut,m,mt,n,nt,asv,asvt);
|
||
|
||
Implement item. */
|
||
|
||
void
|
||
ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
|
||
{
|
||
ffeste_check_item_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
ffebld_dump (u);
|
||
fputc ('(', dmpout);
|
||
ffebld_dump (m);
|
||
fputc (',', dmpout);
|
||
ffebld_dump (n);
|
||
fputs (",U,", dmpout);
|
||
ffebld_dump (asv);
|
||
fputs ("),", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V025_finish -- DEFINE FILE statement list complete
|
||
|
||
ffeste_V025_finish();
|
||
|
||
Just wrap up any local activities. */
|
||
|
||
void
|
||
ffeste_V025_finish ()
|
||
{
|
||
ffeste_check_finish_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputc ('\n', dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
/* ffeste_V026 -- FIND statement
|
||
|
||
ffeste_V026();
|
||
|
||
Make sure a FIND is valid in the current context, and implement it. */
|
||
|
||
void
|
||
ffeste_V026 (ffestpFindStmt *info)
|
||
{
|
||
ffeste_check_simple_ ();
|
||
|
||
#if FFECOM_targetCURRENT == FFECOM_targetFFE
|
||
fputs ("+ FIND (", dmpout);
|
||
ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
|
||
ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
|
||
ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
|
||
ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
|
||
fputs (")\n", dmpout);
|
||
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
|
||
#else
|
||
#error
|
||
#endif
|
||
}
|
||
|
||
#endif
|