int const_eq(Const const1, Const const2) /*;const_eq*/
{
/* checks to see if 2 Consts have the same value */
switch (const_cmp_kind(const1, const2)) {
case CONST_OM:
case CONST_CONSTRAINT_ERROR:
return TRUE;
case CONST_INT:
return (INTV(const1) == INTV(const2));
case CONST_FIXED:
return (FIXEDV(const1) == FIXEDV(const2));
case CONST_UINT:
return int_eql(UINTV(const1), UINTV(const2));
case CONST_REAL:
return (RATV(const1) == RATV(const2));
case CONST_RAT:
return rat_eql(RATV(const1), RATV(const2));
case CONST_STR:
return streq(const1->const_value.const_str,
const2->const_value.const_str);
default:
return const_cmp_undef(const1, const2);
}
}
int compute_index(Tuple subscript_list_arg, Tuple index_list_arg)
/*;compute_index*/
{
/* Evaluate mono-dimensional offset from the given subscripts */
Node subscript, low_node, high_node;
Symbol indx_type;
int ndex, delta; /* use ndex for index, index is builtin */
int sb_val, lw_val, hg_val;
Tuple tup;
Const lw, hg, sb;
Tuple subscript_list, index_list;
/* copy arguments - needed since they are used desctructively in
* tup_frome calls below
*/
subscript_list = tup_copy(subscript_list_arg);
index_list = tup_copy(index_list_arg);
ndex = 0;
delta = 1;
while (tup_size(index_list)) {
indx_type = (Symbol) tup_frome(index_list);
subscript = (Node) tup_frome(subscript_list);
tup = SIGNATURE(indx_type);
low_node = (Node) tup[2];
high_node = (Node) tup[3];
lw = get_ivalue(low_node);
hg = get_ivalue(high_node);
sb = get_ivalue(subscript);
if (!( lw->const_kind != CONST_OM && hg->const_kind != CONST_OM
&& sb->const_kind != CONST_OM)) {
tup_free(subscript_list);
tup_free(index_list);
return -1;
}
sb_val = INTV(sb);
lw_val = INTV(lw);
hg_val = INTV(hg);
if (sb_val<lw_val || sb_val>hg_val) {
/* here, raise constraint_error */
gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
gen(I_RAISE);
tup_free(subscript_list);
tup_free(index_list);
return -1;
}
ndex += delta*(sb_val-lw_val);
delta *= (hg_val-lw_val+1);
}
tup_free(subscript_list);
tup_free(index_list);
return ndex;
}
t_stat rtc_cntr_svc (UNIT *uptr)
{
uint32 cn = uptr - rtc_cntr_unit;
io_sclr_req (INTV (INTG_OVR, cn), 1); /* set cntr intr */
return SCPE_OK;
}
int const_lt(Const cleft, Const cright) /*;const_lt*/
{
switch (const_cmp_kind(cleft, cright)) {
case CONST_INT :
return (INTV(cleft)<INTV(cright));
case CONST_UINT :
return int_lss(UINTV(cleft), UINTV(cright));
case CONST_FIXED :
return (FIXEDV(cleft)<FIXEDV(cright));
case CONST_RAT :
return rat_lss(RATV(cleft), RATV(cright));
case CONST_REAL :
return REALV(cleft) < REALV(cright);
default :
const_cmp_undef(cleft, cright);
return 0;
}
}
void segment_put_const(Segment seg, Const con) /*;segment_put_const*/
{
if (con->const_kind == CONST_INT) {
/* can safely put integers - defer others for later */
segment_put_word(seg, INTV(con));
}
else if(con->const_kind == CONST_REAL) {
segment_put_real(seg, REALV(con));
}
else if(con->const_kind == CONST_FIXED) {
segment_put_long(seg, FIXEDV(con));
}
else {
#ifdef DEBUG
zpcon(con);
#endif
chaos("segment.c - meaningless kind of literal");
}
}
#define MUXDAT_V_LIN 0 /* line num */
#define MUXDAT_M_LIN (MUX_LINES - 1)
#define MUXDAT_V_CHR 8 /* output char */
#define MUXDAT_M_CHR 0xFF
#define MUXDAT_GETLIN(x) (((x) >> MUXDAT_V_LIN) & MUXDAT_M_LIN)
#define MUXDAT_GETCHR(x) (((x) >> MUXDAT_V_CHR) & MUXDAT_M_CHR)
uint8 mux_rbuf[MUX_LINES]; /* rcv buf */
uint8 mux_xbuf[MUX_LINES]; /* xmt buf */
uint8 mux_sta[MUX_LINES]; /* status */
uint32 mux_tps = RTC_HZ_50; /* polls/second */
uint32 mux_scan = 0; /* scanner */
uint32 mux_slck = 0; /* scanner locked */
uint32 muxc_cmd = MUXC_IDLE; /* channel state */
uint32 mux_rint = INTV (INTG_E2, 0);
uint32 mux_xint = INTV (INTG_E2, 1);
TMLN mux_ldsc[MUX_LINES] = { 0 }; /* line descrs */
TMXR mux_desc = { MUX_LINES_DFLT, 0, 0, mux_ldsc }; /* mux descrr */
extern uint32 chan_ctl_time;
extern uint32 CC;
extern uint32 *R;
uint32 mux_disp (uint32 op, uint32 dva, uint32 *dvst);
uint32 mux_dio (uint32 op, uint32 rn, uint32 ad);
uint32 mux_tio_status (void);
t_stat mux_chan_err (uint32 st);
t_stat muxc_svc (UNIT *uptr);
t_stat muxo_svc (UNIT *uptr);
static Const fold_op(Node node) /*;fold_op*/
{
Node opn, arg1, arg2, oplist;
Const result, op1, op2, tryc;
Symbol sym, op_name;
int *uint;
int rm;
Tuple tup;
int res, overflow;
opn = N_AST1(node);
oplist = N_AST2(node);
tup = N_LIST(oplist);
arg1 = (Node) tup[1];
arg2 = (Node) tup[2];
op1 = const_fold(arg1);
op2 = const_fold(arg2);
op_name = N_UNQ(opn);
/* If either operand raises and exception, so does the operation */
if (N_KIND(arg1) == as_raise) {
copy_attributes(arg1, node);
return const_new(CONST_OM);
}
if (N_KIND(arg2) == as_raise
&& op_name != symbol_andthen && op_name != symbol_orelse) {
copy_attributes(arg2, node);
return const_new(CONST_OM);
}
if (is_const_om(op1) || (is_const_om(op2)
&& (op_name != symbol_in || op_name != symbol_notin))) {
return const_new(CONST_OM);
}
sym = op_name;
if ( sym == symbol_addi || sym == symbol_addfl) {
if (sym == symbol_addi) {
res = word_add(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else
result = real_const(REALV(op1) + REALV(op2));
}
else if ( sym == symbol_addfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_add(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_subi) {
if (is_const_int(op1)) {
if (is_const_int(op2)) {
res = word_sub(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
else {
chaos("fold_op: subi operand types");
}
}
}
else if (sym == symbol_subfl) {
result = real_const(REALV(op1) - REALV(op2));
}
else if ( sym == symbol_subfx) {
const_check(op1, CONST_RAT);
const_check(op2, CONST_RAT);
result= rat_const(rat_sub(RATV(op1), RATV(op2)));
}
else if ( sym == symbol_muli) {
#ifdef TBSL
-- need to check for overflow and convert result back to int if not
-- note that low-level setl is missing calls to check_overflow that
-- are present in high-level and should be in low-level as well
result = int_mul(int_fri(op1), int_fri(op2));
#endif
/* until overflow check in */
const_check(op1, CONST_INT);
const_check(op2, CONST_INT);
res = word_mul(INTV(op1), INTV(op2), &overflow);
if (overflow) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else result = int_const(res);
}
static Const fold_unop(Node node) /*;fold_unop*/
{
Node opn, oplist;
Const result, op1;
int op1_kind;
Symbol sym;
opn = N_AST1(node);
oplist = N_AST2(node);
op1 = const_fold((Node) (N_LIST(oplist))[1]);
if (is_const_om(op1)) return op1;
op1_kind = op1->const_kind;
sym = N_UNQ(opn);
if (sym == symbol_addui) {
/* the "+" can be ignored if it is used as a unary op */
result = op1;
}
else if (sym == symbol_addufl) {
result = op1;
}
else if (sym == symbol_addufx) {
result = op1;
}
else if (sym == symbol_subui ||
sym == symbol_subufl || sym == symbol_subufx) {
if (is_simple_value(op1)) {
if (sym == symbol_subui) {
if (is_const_int(op1)) {
if (INTV(op1) == ADA_MIN_INTEGER) {
create_raise(node, symbol_constraint_error);
result = const_new(CONST_OM);
}
else {
result = int_const(-INTV(op1));
}
}
else if (is_const_uint(op1))
result = uint_const(int_umin(UINTV(op1)));
else chaos("eval:subui bad type");
}
else if (sym == symbol_subufl) {
const_check(op1, CONST_REAL);
result = real_const(-REALV(op1));
}
}
else {
const_check(op1, CONST_RAT);
result= rat_const(rat_umin(RATV(op1)));
}
}
else if ( sym == symbol_not) {
if (is_simple_value (op1)) {
if (op1_kind == CONST_INT)
result = int_const(1-INTV(op1)); /*bnot in setl */
else chaos("fold_unop: bad kind");
}
else { /*TBSL*/
result = const_new(CONST_OM);
}
}
else if ( sym == symbol_absi ||
sym == symbol_absfl || sym == symbol_absfx) {
if (is_simple_value(op1)) {
if (sym == symbol_absi) {
if (op1_kind == CONST_INT) result = int_const(abs(INTV(op1)));
else if (op1_kind == CONST_UINT)chaos("fold_unit absi in uint");
else chaos("fold_unop: bad kind");
}
else if (sym == symbol_absfl) {
result = real_const(fabs(REALV(op1)));
}
}
else {
result= rat_const(rat_abs(RATV(op1)));
}
}
return result;
}
