void coerce(oprtype *a,unsigned short new_type)
{
mliteral *lit;
opctype conv, old_op;
triple *ref, *coerc;
assert (new_type == OCT_MVAL || new_type == OCT_MINT || new_type == OCT_BOOL);
assert (a->oprclass == TRIP_REF);
ref = a->oprval.tref;
old_op = ref->opcode;
if (new_type & oc_tab[old_op].octype)
return;
if (old_op == OC_COMVAL || old_op == OC_COMINT)
{
dqdel(ref,exorder);
ref = ref->operand[0].oprval.tref;
old_op = ref->opcode;
if (new_type & oc_tab[old_op].octype)
return;
}
else if (old_op == OC_LIT && new_type == OCT_MINT)
{
lit = ref->operand[0].oprval.mlit;
if (!(++lit->rt_addr))
dqdel(lit, que);
ref->opcode = OC_ILIT;
ref->operand[0].oprclass = ILIT_REF;
ref->operand[0].oprval.ilit = MV_FORCE_INT(&(lit->v));
return;
}
if (new_type == OCT_BOOL)
conv = OC_COBOOL;
else if (new_type == OCT_MINT)
conv = OC_COMINT;
else
conv = OC_COMVAL;
coerc = newtriple(conv);
coerc->operand[0] = put_tref(ref);
*a = put_tref(coerc);
return;
}
void make_commarg(oprtype *x,mint ind)
{
triple *ref;
assert(x->oprclass == TRIP_REF);
ref = x->oprval.tref;
if (ref->opcode != OC_INDGLVN)
{
assert(ref->opcode == OC_COMVAL || ref->opcode == OC_COMINT || ref->opcode == OC_COBOOL);
dqdel(ref,exorder);
assert(ref->operand[0].oprclass == TRIP_REF);
ref = ref->operand[0].oprval.tref;
assert(ref->opcode == OC_INDGLVN);
}
ref->opcode = OC_COMMARG;
ref->operand[1] = put_ilit(ind);
return;
}
void bx_boollit_tail(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr)
/* search the Boolean in t (recursively) for literal leaves; the logic is similar to bx_tail
* the rest of the arguments parallel those in bx_boolop and used primarily handling basic Boolean operations (ON, NOR, AND, NAND)
* to get the jump target and sense right for the left-hand operand of the operation
* jmp_type_one gives the sense of the jump associated with the first operand
* jmp_to_next gives whether we need a second jump to complete the operation
* sense gives the sense of the requested operation
* *addr points the operand for the jump and is eventually used by logic back in the invocation stack to fill in a target location
*/
{
boolean_t sin[ARRAYSIZE(t->operand)], tv[ARRAYSIZE(t->operand)];
int com, comval, dummy, j, neg, num, tvr;
mval *mv, *v[ARRAYSIZE(t->operand)];
opctype c;
oprtype *i, *p;
triple *cob[ARRAYSIZE(t->operand)], *ref0, *tl[ARRAYSIZE(t->operand)];
assert(OCT_BOOL & oc_tab[t->opcode].octype);
assert(TRIP_REF == t->operand[0].oprclass);
assert((OC_COBOOL != t->opcode) && (OC_COM != t->opcode) || (TRIP_REF == t->operand[1].oprclass));
for (i = t->operand, j = 0; i < ARRAYTOP(t->operand); i++, j++)
{ /* checkout an operand to see if we can simplify it */
p = i;
com = 0;
for (tl[j] = i->oprval.tref; OCT_UNARY & oc_tab[(c = tl[j]->opcode)].octype; tl[j] = p->oprval.tref)
{ /* find the real object of affection; WARNING assignment above */
assert((TRIP_REF == tl[j]->operand[0].oprclass) && (NO_REF == tl[j]->operand[1].oprclass));
com ^= (OC_COM == c); /* if we make a recursive call below, COM matters, but NEG and FORCENUM don't */
p = &tl[j]->operand[0];
}
if (OCT_ARITH & oc_tab[c].octype)
ex_tail(p); /* chained arithmetic */
else if (OCT_BOOL & oc_tab[c].octype)
{ /* recursively check an operand */
sin[j] = sense;
p = addr;
if (!j && !(OCT_REL & oc_tab[t->opcode].octype))
{ /* left hand operand of parent */
sin[j] = jmp_type_one;
if (jmp_to_next)
{ /* left operands need extra attention to decide between jump next or to the end */
p = (oprtype *)mcalloc(SIZEOF(oprtype));
*p = put_tjmp(t);
}
}
bx_boollit(tl[j], sin[j] ^ com, p);
}
if ((OC_JMPTRUE != tl[j]->opcode) && (OC_JMPFALSE != tl[j]->opcode) && (OC_LIT != tl[j]->opcode))
return; /* this operation doesn't qualify */
com = comval = neg = num = 0;
cob[j] = NULL;
for (ref0 = i->oprval.tref; OCT_UNARY & oc_tab[(c = ref0->opcode)].octype; ref0 = ref0->operand[0].oprval.tref)
{ /* we may be able to clean up this operand; WARNING assignment above */
assert((TRIP_REF == ref0->operand[0].oprclass) && (NO_REF == ref0->operand[1].oprclass));
num += (OC_FORCENUM == c);
com += (OC_COM == c);
if (!com) /* "outside" com renders neg mute */
neg ^= (OC_NEG == c);
if (!comval && (NULL == cob[j]))
{
if (comval = (OC_COMVAL == c)) /* WARNING assignment */
{
if (ref0 != t->operand[j].oprval.tref)
dqdel(t->operand[j].oprval.tref, exorder);
t->operand[j].oprval.tref = tl[j]; /* need mval: no COBOOL needed */
}
else if (OC_COBOOL == c)
{ /* the operand needs a COBOOL in case its operator remains unresolved */
cob[j] = t->operand[j].oprval.tref;
if (ref0 == cob[j])
continue; /* already where it belongs */
cob[j]->opcode = OC_COBOOL;
cob[j]->operand[0].oprval.tref = tl[j];
} else if (ref0 == t->operand[j].oprval.tref)
continue;
}
dqdel(ref0, exorder);
}
assert(ref0 == tl[j]);
if (!comval && (NULL == cob[j]) && (tl[j] != t->operand[j].oprval.tref))
{ /* left room for a COBOOL, but there's no need */
dqdel(t->operand[j].oprval.tref, exorder);
t->operand[j].oprval.tref = tl[j];
}
if ((OC_JMPTRUE == ref0->opcode) || (OC_JMPFALSE == ref0->opcode))
{ /* switch to a literal representation of TRUE / FALSE */
assert(INDR_REF == ref0->operand[0].oprclass);
ref0->operand[1] = ref0->operand[0]; /* track info as we switch opcode */
PUT_LITERAL_TRUTH((sin[j] ? OC_JMPFALSE : OC_JMPTRUE) == ref0->opcode, ref0);
ref0->opcode = OC_LIT;
com = 0; /* already accounted for by sin */
}
assert((OC_LIT == ref0->opcode) && (MLIT_REF == ref0->operand[0].oprclass));
v[j] = &ref0->operand[0].oprval.mlit->v;
if (com)
{ /* any complement reduces the literal value to [unsigned] 1 or 0 */
unuse_literal(v[j]);
tv[j] = (0 == v[j]->m[1]);
assert(ref0 == tl[j]);
PUT_LITERAL_TRUTH(tv[j], ref0);
v[j] = &ref0->operand[0].oprval.mlit->v;
num = 0; /* any complement trumps num */
}
if (neg || num)
{ /* get literal into uniform state */
unuse_literal(v[j]);
mv = (mval *)mcalloc(SIZEOF(mval));
*mv = *v[j];
if (neg)
{
if (MV_INT & mv->mvtype)
{
if (0 != mv->m[1])
mv->m[1] = -mv->m[1];
else
mv->sgn = 0;
} else if (MV_NM & mv->mvtype)
mv->sgn = !mv->sgn;
} else
s2n(mv);
n2s(mv);
v[j] = mv;
assert(ref0 == tl[j]);
put_lit_s(v[j], ref0);
}
}
assert(tl[0] != tl[1]); /* start processing a live one */
for (tvr = j, j = 0; j < tvr; j++)
{ /* both arguments are literals, so do the operation at compile time */
if (NULL != cob[j])
dqdel(cob[j], exorder);
v[j] = &tl[j]->operand[0].oprval.mlit->v;
tv[j] = (0 != v[j]->m[1]);
unuse_literal(v[j]);
tl[j]->opcode = OC_NOOP;
tl[j]->operand[0].oprclass = NO_REF;
}
t->operand[1].oprclass = NO_REF;
switch (c = t->opcode) /* WARNING assignment */
{ /* optimize the Boolean operations here */
case OC_NAND:
case OC_AND:
tvr = (tv[0] && tv[1]);
break;
case OC_NOR:
case OC_OR:
tvr = (tv[0] || tv[1]);
break;
case OC_NCONTAIN:
case OC_CONTAIN:
tvr = 1;
(void)matchc(v[1]->str.len, (unsigned char *)v[1]->str.addr, v[0]->str.len,
(unsigned char *)v[0]->str.addr, &dummy, &tvr);
tvr ^= 1;
break;
case OC_NEQU:
case OC_EQU:
tvr = is_equ(v[0], v[1]);
break;
case OC_NFOLLOW:
case OC_FOLLOW:
tvr = 0 < memvcmp(v[0]->str.addr, v[0]->str.len, v[1]->str.addr, v[1]->str.len);
break;
case OC_NGT:
case OC_GT:
tvr = 0 < numcmp(v[0], v[1]);
break;
case OC_NLT:
case OC_LT:
tvr = 0 > numcmp(v[0], v[1]);
break;
case OC_NPATTERN:
case OC_PATTERN:
tvr = !(*(uint4 *)v[1]->str.addr) ? do_pattern(v[0], v[1]) : do_patfixed(v[0], v[1]);
break;
case OC_NSORTS_AFTER:
case OC_SORTS_AFTER:
tvr = 0 < sorts_after(v[0], v[1]);
break;
default:
assertpro(FALSE);
}
tvr ^= !sense;
t->operand[0] = put_indr(addr);
t->opcode = tvr ? OC_JMPFALSE : OC_JMPTRUE;
return;
}
int m_merge(void)
{
int type;
boolean_t used_glvn_slot;
mval mv;
opctype put_oc;
oprtype mopr, control_slot;
triple *obp, *ref, *restart, *s1, *sub, tmpchain;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
used_glvn_slot = FALSE;
sub = NULL;
restart = newtriple(OC_RESTARTPC); /* Here is where a restart should pick up */
dqinit(&tmpchain, exorder);
/* Left Hand Side of EQUAL sign */
switch (TREF(window_token))
{
case TK_IDENT:
if (!lvn(&mopr, OC_PUTINDX, 0))
return FALSE;
if (OC_PUTINDX == mopr.oprval.tref->opcode)
{ /* we insert left hand side argument into tmpchain. */
sub = mopr.oprval.tref;
put_oc = OC_PUTINDX;
dqdel(mopr.oprval.tref, exorder);
dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref);
}
ref = maketriple(OC_MERGE_LVARG);
ref->operand[0] = put_ilit(MARG1_LCL);
ref->operand[1] = mopr;
dqins(tmpchain.exorder.bl, exorder, ref);
break;
case TK_CIRCUMFLEX:
s1 = (TREF(curtchain))->exorder.bl;
if (!gvn())
return FALSE;
assert(OC_GVRECTARG != (TREF(curtchain))->opcode); /* we count on gvn not having been shifted */
for (sub = (TREF(curtchain))->exorder.bl; sub != s1; sub = sub->exorder.bl)
{
put_oc = sub->opcode;
if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
break;
}
assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc) || (OC_GVEXTNAM == put_oc));
/* we insert left hand side argument into tmpchain. */
dqdel(sub, exorder);
dqins(tmpchain.exorder.bl ,exorder, sub);
ref = maketriple(OC_MERGE_GVARG);
ref->operand[0] = put_ilit(MARG1_GBL);
dqins(tmpchain.exorder.bl, exorder, ref);
break;
case TK_ATSIGN:
if (!indirection(&mopr))
return FALSE;
if (TK_EQUAL != TREF(window_token))
{
ref = newtriple(OC_COMMARG);
ref->operand[0] = mopr;
ref->operand[1] = put_ilit((mint) indir_merge);
return TRUE;
}
type = MARG1_LCL | MARG1_GBL;
memset(&mv, 0, SIZEOF(mval)); /* Initialize so unused fields don't cause object hash differences */
MV_FORCE_MVAL(&mv, type);
MV_FORCE_STRD(&mv);
if (TREF(side_effect_handling))
{ /* save and restore the variable lookup for true left-to-right evaluation */
used_glvn_slot = TRUE;
INSERT_INDSAVGLVN(control_slot, mopr, ANY_SLOT, 0); /* 0 flag to defer global reference */
ref = maketriple(OC_INDMERGE2);
ref->operand[0] = control_slot;
} else
{ /* quick and dirty old way */
ref = maketriple(OC_INDMERGE);
ref->operand[0] = put_lit(&mv);
ref->operand[1] = mopr;
}
/* we insert left hand side argument into tmpchain. */
dqins(tmpchain.exorder.bl, exorder, ref);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (TREF(window_token) != TK_EQUAL)
{
stx_error(ERR_EQUAL);
return FALSE;
}
advancewindow();
/* Right Hand Side of EQUAL sign */
TREF(temp_subs) = FALSE;
switch (TREF(window_token))
{
case TK_IDENT:
if (!lvn(&mopr, OC_M_SRCHINDX, 0))
return FALSE;
ref = newtriple(OC_MERGE_LVARG);
ref->operand[0] = put_ilit(MARG2_LCL);
ref->operand[1] = mopr;
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
ref = newtriple(OC_MERGE_GVARG);
ref->operand[0] = put_ilit(MARG2_GBL);
break;
case TK_ATSIGN:
TREF(temp_subs) = TRUE;
if (!indirection(&mopr))
{
stx_error(ERR_VAREXPECTED);
return FALSE;
}
type = MARG2_LCL | MARG2_GBL;
memset(&mv, 0, SIZEOF(mval)); /* Initialize so unused fields don't cause object hash differences */
MV_FORCE_MVAL(&mv, type);
MV_FORCE_STRD(&mv);
ref = maketriple(OC_INDMERGE);
ref->operand[0] = put_lit(&mv);
ref->operand[1] = mopr;
ins_triple(ref);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
/*
* Make sure that during runtime right hand side argument is processed first.
* This is specially important if global naked variable is used .
*/
obp = (TREF(curtchain))->exorder.bl;
dqadd(obp, &tmpchain, exorder);
if (TREF(temp_subs) && TREF(side_effect_handling) && sub)
create_temporaries(sub, put_oc);
TREF(temp_subs) = FALSE;
if (used_glvn_slot)
{
ref = newtriple(OC_GLVNPOP);
ref->operand[0] = control_slot;
}
ref = newtriple(OC_MERGE);
return TRUE;
}
int f_order(oprtype *a, opctype op)
{
boolean_t ok, used_glvn_slot;
enum order_dir direction;
enum order_obj object;
int4 intval;
opctype gv_oc;
oprtype control_slot, dir_opr, *dir_oprptr, *next_oprptr;
short int column;
triple *oldchain, *r, *sav_dirref, *sav_gv1, *sav_gvn, *sav_lvn, *sav_ref, *share, *triptr;
triple *chain2, *obp, tmpchain2;
save_se save_state;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
oldchain = sav_dirref = NULL; /* default to no direction and no shifting indirection */
used_glvn_slot = FALSE;
sav_gv1 = TREF(curtchain);
r = maketriple(OC_NOOP); /* We'll fill in the opcode later, when we figure out what it is */
switch (TREF(window_token))
{
case TK_IDENT:
if (TK_LPAREN == TREF(director_token))
{
object = LOCAL;
ok = lvn(&r->operand[0], OC_SRCHINDX, r); /* 2nd arg causes us to mess below with return from lvn */
} else
{
object = LOCAL_NAME;
ok = TRUE;
r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
advancewindow();
}
next_oprptr = &r->operand[1];
break;
case TK_CIRCUMFLEX:
object = GLOBAL;
ok = gvn();
sav_gvn = (TREF(curtchain))->exorder.bl;
next_oprptr = &r->operand[0];
break;
case TK_ATSIGN:
object = INDIRECT;
if (SHIFT_SIDE_EFFECTS)
START_GVBIND_CHAIN(&save_state, oldchain);
ok = indirection(&r->operand[0]);
next_oprptr = &r->operand[1];
break;
default:
ok = FALSE;
break;
}
if (!ok)
{
if (NULL != oldchain)
setcurtchain(oldchain);
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (TK_COMMA != TREF(window_token))
direction = FORWARD; /* default direction */
else
{ /* two argument form: ugly logic for direction */
advancewindow();
column = source_column;
dir_oprptr = (oprtype *)mcalloc(SIZEOF(oprtype));
dir_opr = put_indr(dir_oprptr);
sav_ref = newtriple(OC_GVSAVTARG);
DISABLE_SIDE_EFFECT_AT_DEPTH; /* doing this here let's us know specifically if direction had SE threat */
if (EXPR_FAIL == expr(dir_oprptr, MUMPS_EXPR))
{
if (NULL != oldchain)
setcurtchain(oldchain);
return FALSE;
}
assert(TRIP_REF == dir_oprptr->oprclass);
triptr = dir_oprptr->oprval.tref;
if (OC_LIT == triptr->opcode)
{ /* if direction is a literal - pick it up and stop flailing about */
if (MV_IS_TRUEINT(&triptr->operand[0].oprval.mlit->v, &intval) && (1 == intval || -1 == intval))
{
direction = (1 == intval) ? FORWARD : BACKWARD;
sav_ref->opcode = OC_NOOP;
sav_ref = NULL;
} else
{ /* bad direction */
if (NULL != oldchain)
setcurtchain(oldchain);
stx_error(ERR_ORDER2);
return FALSE;
}
} else
{
direction = TBD;
sav_dirref = newtriple(OC_GVSAVTARG); /* $R reflects direction eval even if we revisit 1st arg */
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(sav_ref);
switch (object)
{
case GLOBAL: /* The direction may have had a side effect, so take copies of subscripts */
*next_oprptr = *dir_oprptr;
for (; sav_gvn != sav_gv1; sav_gvn = sav_gvn->exorder.bl)
{ /* hunt down the gv opcode */
gv_oc = sav_gvn->opcode;
if ((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc))
break;
}
assert((OC_GVNAME == gv_oc) || (OC_GVNAKED == gv_oc) || (OC_GVEXTNAM == gv_oc));
TREF(temp_subs) = TRUE;
create_temporaries(sav_gvn, gv_oc);
break;
case LOCAL: /* Additionally need to move srchindx triple to after potential side effect */
triptr = newtriple(OC_PARAMETER);
triptr->operand[0] = *next_oprptr;
triptr->operand[1] = *(&dir_opr);
*next_oprptr = put_tref(triptr);
sav_lvn = r->operand[0].oprval.tref;
assert((OC_SRCHINDX == sav_lvn->opcode) || (OC_VAR == sav_lvn->opcode));
if (OC_SRCHINDX == sav_lvn->opcode)
{
dqdel(sav_lvn, exorder);
ins_triple(sav_lvn);
TREF(temp_subs) = TRUE;
create_temporaries(sav_lvn, OC_SRCHINDX);
}
assert(&r->operand[1] == next_oprptr);
assert(TRIP_REF == next_oprptr->oprclass);
assert(OC_PARAMETER == next_oprptr->oprval.tref->opcode);
assert(TRIP_REF == next_oprptr->oprval.tref->operand[0].oprclass);
sav_lvn = next_oprptr->oprval.tref->operand[0].oprval.tref;
if ((OC_VAR == sav_lvn->opcode) || (OC_GETINDX == sav_lvn->opcode))
{ /* lvn excludes the last subscript from srchindx and attaches it to the "parent"
* now we find it is an lvn and needs protection too
*/
triptr = maketriple(OC_STOTEMP);
triptr->operand[0] = put_tref(sav_lvn);
dqins(sav_lvn, exorder, triptr); /* NOTE: violation of info hiding */
next_oprptr->oprval.tref->operand[0].oprval.tref = triptr;
}
break;
case INDIRECT: /* Save and restore the variable lookup for true left-to-right evaluation */
*next_oprptr = *dir_oprptr;
used_glvn_slot = TRUE;
dqinit(&tmpchain2, exorder);
chain2 = setcurtchain(&tmpchain2);
INSERT_INDSAVGLVN(control_slot, r->operand[0], ANY_SLOT, 1);
setcurtchain(chain2);
obp = sav_ref->exorder.bl; /* insert before second arg */
dqadd(obp, &tmpchain2, exorder);
r->operand[0] = control_slot;
break;
case LOCAL_NAME: /* left argument is a string - side effect can't screw it up */
*next_oprptr = *dir_oprptr;
break;
default:
assert(FALSE);
}
ins_triple(r);
if (used_glvn_slot)
{
triptr = newtriple(OC_GLVNPOP);
triptr->operand[0] = control_slot;
}
if (SE_WARN_ON && (TREF(side_effect_base))[TREF(expr_depth)])
ISSUE_SIDEEFFECTEVAL_WARNING(column - 1);
DISABLE_SIDE_EFFECT_AT_DEPTH; /* usual side effect processing doesn't work for $ORDER() */
}
}
if (TBD != direction)
ins_triple(r);
if (NULL != sav_dirref)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(sav_dirref);
}
r->opcode = order_opc[object][direction]; /* finally - the op code */
if (NULL != oldchain)
PLACE_GVBIND_CHAIN(&save_state, oldchain); /* shift chain back to "expr_start" */
if (OC_FNLVNAME == r->opcode)
*next_oprptr = put_ilit(0); /* Flag not to return aliases with no value */
if (OC_INDFUN == r->opcode)
*next_oprptr = put_ilit((mint)((FORWARD == direction) ? indir_fnorder1 : indir_fnzprevious));
*a = put_tref(r);
return TRUE;
}
int m_merge(void)
{
error_def(ERR_VAREXPECTED);
error_def(ERR_RPARENMISSING);
error_def(ERR_EQUAL);
opctype put_oc;
oprtype mopr;
triple *sub, *ref, *obp, *s1, *restart, tmpchain;
mval mv;
int type;
restart = newtriple(OC_RESTARTPC); /* Here is where a restart should pick up */
dqinit(&tmpchain, exorder);
/* Left Hand Side of EQUAL sign */
switch (window_token)
{
case TK_IDENT:
if (!lvn(&mopr, OC_PUTINDX, 0))
return FALSE;
if (OC_PUTINDX == mopr.oprval.tref->opcode);
{
/* we insert left hand side argument into tmpchain. */
dqdel(mopr.oprval.tref, exorder);
dqins(tmpchain.exorder.bl, exorder, mopr.oprval.tref);
}
ref = maketriple(OC_MERGE_LVARG);
ref->operand[0] = put_ilit(MARG1_LCL);
ref->operand[1] = mopr;
dqins(tmpchain.exorder.bl, exorder, ref);
break;
case TK_CIRCUMFLEX:
s1 = curtchain->exorder.bl;
if (!gvn())
return FALSE;
for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl)
{
put_oc = sub->opcode;
if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
break;
}
assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc);
/* we insert left hand side argument into tmpchain. */
dqdel(sub, exorder);
dqins(tmpchain.exorder.bl ,exorder, sub);
ref = maketriple(OC_MERGE_GVARG);
ref->operand[0] = put_ilit(MARG1_GBL);
dqins(tmpchain.exorder.bl, exorder, ref);
break;
case TK_ATSIGN:
if (!indirection(&mopr))
return FALSE;
if (window_token != TK_EQUAL)
{
ref = newtriple(OC_COMMARG);
ref->operand[0] = mopr;
ref->operand[1] = put_ilit((mint) indir_merge);
ins_triple(ref);
return TRUE;
}
type = MARG1_LCL | MARG1_GBL;
MV_FORCE_MVAL(&mv, type);
MV_FORCE_STR(&mv);
ref = maketriple(OC_INDMERGE);
ref->operand[0] = put_lit(&mv);
ref->operand[1] = mopr;
/* we insert left hand side argument into tmpchain. */
dqins(tmpchain.exorder.bl, exorder, ref);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (window_token != TK_EQUAL)
{
stx_error(ERR_EQUAL);
return FALSE;
}
advancewindow();
/* Right Hand Side of EQUAL sign */
switch (window_token)
{
case TK_IDENT:
if (!lvn(&mopr, OC_M_SRCHINDX, 0))
return FALSE;
ref = newtriple(OC_MERGE_LVARG);
ref->operand[0] = put_ilit(MARG2_LCL);
ref->operand[1] = mopr;
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
ref = newtriple(OC_MERGE_GVARG);
ref->operand[0] = put_ilit(MARG2_GBL);
break;
case TK_ATSIGN:
if (!indirection(&mopr))
{
stx_error(ERR_VAREXPECTED);
return FALSE;
}
type = MARG2_LCL | MARG2_GBL;
MV_FORCE_MVAL(&mv, type);
MV_FORCE_STR(&mv);
ref = maketriple(OC_INDMERGE);
ref->operand[0] = put_lit(&mv);
ref->operand[1] = mopr;
ins_triple(ref);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
/*
* Make sure that during runtime right hand side argument is processed first.
* This is specially important if global naked variable is used .
*/
obp = curtchain->exorder.bl;
dqadd(obp, &tmpchain, exorder);
ref = newtriple(OC_MERGE);
return TRUE;
}
int m_set(void)
{
/* Some comment on "parse_warn". It is set to TRUE whenever the parse encounters an
invalid setleft target.
* Note that even if "parse_warn" is TRUE, we should not return FALSE right away but need to continue the parse
* until the end of the current SET command. This way any remaining commands in the current parse line will be
* parsed and triples generated for them. This is necessary just in case the currently parsed invalid SET command
* does not get executed at runtime (due to postconditionals etc.)
*
* Some comment on the need for "first_setleft_invalid". This variable is needed only in the
* case we encounter an invalid-SVN/invalid-FCN/unsettable-SVN as a target of the SET. We need to evaluate the
* right-hand-side of the SET command only if at least one valid setleft target is parsed before an invalid setleft
* target is encountered. This is because we still need to execute the valid setlefts at runtime before triggering
* a runtime error for the invalid setleft. If the first setleft target is an invalid one, then there is no need
* to evaluate the right-hand-side. In fact, in this case, adding triples (corresponding to the right hand side)
* to the execution chain could cause problems with emit_code later in the compilation as the destination
* for the right hand side triples could now be undefined (for example a valid SVN on the left side of the
* SET would have generated an OC_SVPUT triple with one of its operands holding the result of the right
* hand side evaluation, but an invalid SVN on the left side which would have instead caused an OC_RTERROR triple
* to have been generated leaving no triple to receive the result of the right hand side evaluation thus causing
* emit_code to be confused and GTMASSERT). Therefore discard all triples generated by the right hand side in this case.
* By the same reasoning, discard all triples generated by setleft targets AFTER this invalid one as well.
* "first_setleft_invalid" is set to TRUE if the first setleft target is invalid and set to FALSE if the first setleft
* target is valid. It is initialized to -1 before the start of the parse.
*/
int index, setop, delimlen;
int first_val_lit, last_val_lit, nakedzalias;
boolean_t first_is_lit, last_is_lit, got_lparen, delim1char, is_extract, valid_char;
boolean_t alias_processing, have_lh_alias;
opctype put_oc;
oprtype v, delimval, firstval, lastval, *result, resptr;
triple *curtargchain, *delimiter, discardcurtchain, *first, *get, *jmptrp1, *jmptrp2, *last, *obp, *put;
triple *s, *s0, *s1, save_targchain, *save_curtchain, *save_curtchain1, *sub, targchain, *tmp;
mint delimlit;
mval *delim_mval;
mvar *mvarptr;
boolean_t parse_warn; /* set to TRUE in case of an invalid SVN etc. */
boolean_t curtchain_switched; /* set to TRUE if a setcurtchain was done */
int first_setleft_invalid; /* set to TRUE if the first setleft target is invalid */
boolean_t temp_subs_was_FALSE;
union
{
uint4 unichar_val;
unsigned char unibytes_val[4];
} unichar;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
TREF(temp_subs) = FALSE;
dqinit(&targchain, exorder);
result = (oprtype *)mcalloc(SIZEOF(oprtype));
resptr = put_indr(result);
delimiter = sub = last = NULL;
/* A SET clause must be entirely alias related or a normal set. Parenthized multiple sets of aliases are not allowed
* and will trigger an error. This is because the source and targets of aliases require different values and references
* than normal sets do and thus cannot be mixed.
*/
if (alias_processing = (TK_ASTERISK == window_token))
advancewindow();
if (got_lparen = (TK_LPAREN == window_token))
{
if (alias_processing)
stx_error(ERR_NOALIASLIST);
advancewindow();
TREF(temp_subs) = TRUE;
}
/* Some explanation: The triples from the left hand side of the SET expression that are
* expressly associated with fetching (in case of set $piece/$extract) and/or storing of
* the target value are removed from curtchain and placed on the targchain. Later, these
* triples will be added to the end of curtchain to do the finishing store of the target
* after the righthand side has been evaluated. This is per the M standard.
*
* Note that SET $PIECE/$EXTRACT have special conditions in which the first argument is not referenced at all.
* (e.g. set $piece(^a," ",3,2) in this case 3 > 2 so this should not evaluate ^a and therefore should not
* modify the naked indicator). That is, the triples that do these conditional checks need to be inserted
* ahead of the OC_GVNAME of ^a, all of which need to be inserted on the targchain. But the conditionalization
* can be done only after parsing the first argument of the SET $PIECE and examining the remaining arguments.
* Therefore we maintain the "curtargchain" variable which stores the value of the "targchain" at the beginning
* of the iteration (at the start of the $PIECE parsing) and all the conditionalization will be inserted right
* here which is guaranteed to be ahead of where the OC_GVNAME gets inserted.
*
* For example, SET $PIECE(^A(x,y),delim,first,last)=RHS will generate a final triple chain as follows
*
* A - Triples to evaluate subscripts (x,y) of the global ^A
* A - Triples to evaluate delim
* A - Triples to evaluate first
* A - Triples to evaluate last
* B - Triples to evaluate RHS
* C - Triples to do conditional check (e.g. first > last etc.)
* C - Triples to branch around if the checks indicate this is a null operation SET $PIECE
* D - Triple that does OC_GVNAME of ^A
* D - Triple that does OC_SETPIECE to determine the new value
* D - Triple that does OC_GVPUT of the new value into ^A(x,y)
* This is the point where the conditional check triples will branch around to if they chose to.
*
* A - triples that evaluates the arguments/subscripts in the left-hand-side of the SET command
* These triples are built in "curtchain"
* B - triples that evaluates the arguments/subscripts in the right-hand-side of the SET command
* These triples are built in "curtchain"
* C - triples that do conditional check for any $PIECE/$EXTRACT in the left side of the SET command.
* These triples are built in "curtargchain"
* D - triples that generate the reference to the target of the SET and the store into the target.
* These triples are built in "targchain"
*
* Note alias processing does not support the SET *(...)=.. type syntax because the type of argument
* created for RHS processing is dependent on the LHS receiver type and we do not support more than one
* type of source argument in a single SET.
*/
first_setleft_invalid = FIRST_SETLEFT_NOTSEEN;
curtchain_switched = FALSE;
nakedzalias = have_lh_alias = FALSE;
save_curtchain = NULL;
assert(FIRST_SETLEFT_NOTSEEN != TRUE);
assert(FIRST_SETLEFT_NOTSEEN != FALSE);
for (parse_warn = FALSE; ; parse_warn = FALSE)
{
curtargchain = targchain.exorder.bl;
jmptrp1 = jmptrp2 = NULL;
delim1char = is_extract = FALSE;
allow_dzwrtac_as_mident(); /* Allows $ZWRTACxxx as target to be treated as an mident */
switch (window_token)
{
case TK_IDENT:
/* A slight diversion first. If this is a $ZWRTAC set (indication of $ in first char
* is currently enough to signify that), then we need to check a few conditions first.
* If this is a "naked $ZWRTAC", meaning no numeric suffix, then this is a flag that
* all the $ZWRTAC vars in the local variable tree need to be kill *'d which will not
* be generating a SET instruction. First we need to verify that fact and make sure
* we are not in PARENs and not doing alias processing. Note *any* value can be
* specified as the source but while it will be evaluated, it is NOT stored anywhere.
*/
if ('$' == *window_ident.addr)
{ /* We have a $ZWRTAC<xx> target */
if (got_lparen)
/* We don't allow $ZWRTACxxx to be specified in a parenthesized list.
* Verify that first
*/
SYNTAX_ERROR(ERR_DZWRNOPAREN);
if (STR_LIT_LEN(DOLLAR_ZWRTAC) == window_ident.len)
{ /* Ok, this is a naked $ZWRTAC targeted set */
if (alias_processing)
SYNTAX_ERROR(ERR_DZWRNOALIAS);
nakedzalias = TRUE;
/* This opcode doesn't really need args but it is easier to fit in with the rest
* of m_set processing to pass it the result arg, which there may actually be
* a use for someday..
*/
put = maketriple(OC_CLRALSVARS);
put->operand[0] = resptr;
dqins(targchain.exorder.bl, exorder, put);
advancewindow();
break;
}
}
/* If we are doing alias processing, there are two possibilities:
* 1) LHS is unsubscripted - it is an alias variable being created or replaced. Need to parse
* the varname as if this were a regular set.
* 2) LHS is subscripted - it is an alias container variable being created or replaced. The
* processing here is to pass the base variable index to the store routine so bypass the
* lvn() call.
*/
if (!alias_processing || TK_LPAREN == director_token)
{ /* Normal variable processing or we have a lh alias container */
if (!lvn(&v, OC_PUTINDX, 0))
SYNTAX_ERROR_NOREPORT_HERE;
if (OC_PUTINDX == v.oprval.tref->opcode)
{
dqdel(v.oprval.tref, exorder);
dqins(targchain.exorder.bl, exorder, v.oprval.tref);
sub = v.oprval.tref;
put_oc = OC_PUTINDX;
if (TREF(temp_subs))
m_set_create_temporaries(sub, put_oc);
}
} else
{ /* Have alias variable. Argument is index into var table rather than pointer to var */
have_lh_alias = TRUE;
/* We only want the variable index in this case. Since the entire hash structure to which
* this variable is going to be pointing to is changing, doing anything that calls fetch()
* is somewhat pointless so we avoid it by just accessing the variable information
* directly.
*/
mvarptr = get_mvaddr(&window_ident);
v = put_ilit(mvarptr->mvidx);
advancewindow();
}
/* Determine correct storing triple */
put = maketriple((!alias_processing ? OC_STO :
(have_lh_alias ? OC_SETALS2ALS : OC_SETALSIN2ALSCT)));
put->operand[0] = v;
put->operand[1] = resptr;
dqins(targchain.exorder.bl, exorder, put);
break;
case TK_CIRCUMFLEX:
if (alias_processing)
SYNTAX_ERROR(ERR_ALIASEXPECTED);
s1 = curtchain->exorder.bl;
if (!gvn())
SYNTAX_ERROR_NOREPORT_HERE;
for (sub = curtchain->exorder.bl; sub != s1; sub = sub->exorder.bl)
{
put_oc = sub->opcode;
if (OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc)
break;
}
assert(OC_GVNAME == put_oc || OC_GVNAKED == put_oc || OC_GVEXTNAM == put_oc);
dqdel(sub, exorder);
dqins(targchain.exorder.bl, exorder, sub);
if (TREF(temp_subs))
m_set_create_temporaries(sub, put_oc);
put = maketriple(OC_GVPUT);
put->operand[0] = resptr;
dqins(targchain.exorder.bl, exorder, put);
break;
case TK_ATSIGN:
if (alias_processing)
SYNTAX_ERROR(ERR_ALIASEXPECTED);
if (!indirection(&v))
SYNTAX_ERROR_NOREPORT_HERE;
if (!got_lparen && TK_EQUAL != window_token)
{
assert(!curtchain_switched);
put = newtriple(OC_COMMARG);
put->operand[0] = v;
put->operand[1] = put_ilit(indir_set);
return TRUE;
}
put = maketriple(OC_INDSET);
put->operand[0] = v;
put->operand[1] = resptr;
dqins(targchain.exorder.bl, exorder, put);
break;
case TK_DOLLAR:
if (alias_processing)
SYNTAX_ERROR(ERR_ALIASEXPECTED);
advancewindow();
if (TK_IDENT != window_token)
SYNTAX_ERROR(ERR_VAREXPECTED);
if (TK_LPAREN != director_token)
{ /* Look for intrinsic special variables */
s1 = curtchain->exorder.bl;
if (0 > (index = namelook(svn_index, svn_names, window_ident.addr, window_ident.len)))
{
STX_ERROR_WARN(ERR_INVSVN); /* sets "parse_warn" to TRUE */
} else if (!svn_data[index].can_set)
{
STX_ERROR_WARN(ERR_SVNOSET); /* sets "parse_warn" to TRUE */
}
advancewindow();
if (!parse_warn)
{
if (SV_ETRAP != svn_data[index].opcode && SV_ZTRAP != svn_data[index].opcode)
{ /* Setting of $ZTRAP or $ETRAP must go through opp_svput because they
* may affect the stack pointer. All others directly to op_svput().
*/
put = maketriple(OC_SVPUT);
} else
put = maketriple(OC_PSVPUT);
put->operand[0] = put_ilit(svn_data[index].opcode);
put->operand[1] = resptr;
dqins(targchain.exorder.bl, exorder, put);
} else
{ /* OC_RTERROR triple would have been inserted in curtchain by ins_errtriple
* (invoked by stx_error). To maintain consistency with the "if" portion of
* this code, we need to move this triple to the "targchain".
*/
tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */
tmp = tmp->exorder.bl; /* corresponds to put_ilit(in_error) in ins_errtriple */
tmp = tmp->exorder.bl; /* corresponds to newtriple(OC_RTERROR) in ins_errtriple */
assert(OC_RTERROR == tmp->opcode);
dqdel(tmp, exorder);
dqins(targchain.exorder.bl, exorder, tmp);
CHKTCHAIN(&targchain);
}
break;
}
/* Only 4 function names allowed on left side: $[Z]Piece and $[Z]Extract */
index = namelook(fun_index, fun_names, window_ident.addr, window_ident.len);
if (0 > index)
{
STX_ERROR_WARN(ERR_INVFCN); /* sets "parse_warn" to TRUE */
/* OC_RTERROR triple would have been inserted in "curtchain" by ins_errtriple
* (invoked by stx_error). We need to switch it to "targchain" to be consistent
* with every other codepath in this module.
*/
tmp = curtchain->exorder.bl; /* corresponds to put_ilit(FALSE) in ins_errtriple */
tmp = tmp->exorder.bl; /* corresponds to put_ilit(in_error) in ins_errtriple */
tmp = tmp->exorder.bl; /* corresponds to newtriple(OC_RTERROR) in ins_errtriple */
assert(OC_RTERROR == tmp->opcode);
dqdel(tmp, exorder);
dqins(targchain.exorder.bl, exorder, tmp);
CHKTCHAIN(&targchain);
advancewindow(); /* skip past the function name */
advancewindow(); /* skip past the left paren */
/* Parse the remaining arguments until corresponding RIGHT-PAREN/SPACE/EOL is reached */
if (!parse_until_rparen_or_space())
SYNTAX_ERROR_NOREPORT_HERE;
} else
{
switch(fun_data[index].opcode)
{
case OC_FNPIECE:
setop = OC_SETPIECE;
break;
case OC_FNEXTRACT:
is_extract = TRUE;
setop = OC_SETEXTRACT;
break;
case OC_FNZPIECE:
setop = OC_SETZPIECE;
break;
case OC_FNZEXTRACT:
is_extract = TRUE;
setop = OC_SETZEXTRACT;
break;
default:
SYNTAX_ERROR(ERR_VAREXPECTED);
}
advancewindow();
advancewindow();
/* Although we see the get (target) variable first, we need to save it's processing
* on another chain -- the targchain -- because the retrieval of the target is bypassed
* and the naked indicator is not reset if the first/last parameters are not set in a
* logical manner (must be > 0 and first <= last). So the evaluation order is
* delimiter (if $piece), first, last, RHS of the set and then the target if applicable.
* Set up primary action triple now since it is ref'd by the put triples generated below.
*/
s = maketriple(setop);
/* Even for SET[Z]PIECE and SET[Z]EXTRACT, the SETxxxxx opcodes
* do not do the final store, they only create the final value TO be
* stored so generate the triples that will actually do the store now.
* Note we are still building triples on the original curtchain.
*/
switch (window_token)
{
case TK_IDENT:
if (!lvn(&v, OC_PUTINDX, 0))
SYNTAX_ERROR(ERR_VAREXPECTED);
if (OC_PUTINDX == v.oprval.tref->opcode)
{
dqdel(v.oprval.tref, exorder);
dqins(targchain.exorder.bl, exorder, v.oprval.tref);
sub = v.oprval.tref;
put_oc = OC_PUTINDX;
if (TREF(temp_subs))
m_set_create_temporaries(sub, put_oc);
}
get = maketriple(OC_FNGET);
get->operand[0] = v;
put = maketriple(OC_STO);
put->operand[0] = v;
put->operand[1] = put_tref(s);
break;
case TK_ATSIGN:
if (!indirection(&v))
SYNTAX_ERROR(ERR_VAREXPECTED);
get = maketriple(OC_INDGET);
get->operand[0] = v;
get->operand[1] = put_str(0, 0);
put = maketriple(OC_INDSET);
put->operand[0] = v;
put->operand[1] = put_tref(s);
break;
case TK_CIRCUMFLEX:
s1 = curtchain->exorder.bl;
if (!gvn())
SYNTAX_ERROR_NOREPORT_HERE;
for (sub = curtchain->exorder.bl; sub != s1 ; sub = sub->exorder.bl)
{
put_oc = sub->opcode;
if ((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc)
|| (OC_GVEXTNAM == put_oc))
break;
}
assert((OC_GVNAME == put_oc) || (OC_GVNAKED == put_oc)
|| (OC_GVEXTNAM == put_oc));
dqdel(sub, exorder);
dqins(targchain.exorder.bl, exorder, sub);
if (TREF(temp_subs))
m_set_create_temporaries(sub, put_oc);
get = maketriple(OC_FNGVGET);
get->operand[0] = put_str(0, 0);
put = maketriple(OC_GVPUT);
put->operand[0] = put_tref(s);
break;
default:
SYNTAX_ERROR(ERR_VAREXPECTED);
}
s->operand[0] = put_tref(get);
/* Code to fetch args for target triple are on targchain. Put get there now too. */
dqins(targchain.exorder.bl, exorder, get);
CHKTCHAIN(&targchain);
if (!is_extract)
{ /* Set $[z]piece */
delimiter = newtriple(OC_PARAMETER);
s->operand[1] = put_tref(delimiter);
first = newtriple(OC_PARAMETER);
delimiter->operand[1] = put_tref(first);
/* Process delimiter string ($[z]piece only) */
if (TK_COMMA != window_token)
SYNTAX_ERROR(ERR_COMMA);
advancewindow();
if (!strexpr(&delimval))
SYNTAX_ERROR_NOREPORT_HERE;
assert(TRIP_REF == delimval.oprclass);
} else
{ /* Set $[Z]Extract */
first = newtriple(OC_PARAMETER);
s->operand[1] = put_tref(first);
}
/* Process first integer value */
if (window_token != TK_COMMA)
firstval = put_ilit(1);
else
{
advancewindow();
if (!intexpr(&firstval))
SYNTAX_ERROR(ERR_COMMA);
assert(firstval.oprclass == TRIP_REF);
}
first->operand[0] = firstval;
if (first_is_lit = (OC_ILIT == firstval.oprval.tref->opcode))
{
assert(ILIT_REF ==firstval.oprval.tref->operand[0].oprclass);
first_val_lit = firstval.oprval.tref->operand[0].oprval.ilit;
}
if (TK_COMMA != window_token)
{ /* There is no "last" value. Only if 1 char literal delimiter and
* no "last" value can we generate shortcut code to op_set[z]p1 entry
* instead of op_set[z]piece. Note if UTF8 mode is in effect, then this
* optimization applies if the literal is one unicode char which may in
* fact be up to 4 bytes but will still be passed as a single unsigned
* integer.
*/
if (!is_extract)
{
delim_mval = &delimval.oprval.tref->operand[0].oprval.mlit->v;
valid_char = TRUE; /* Basic assumption unles proven otherwise */
if (delimval.oprval.tref->opcode == OC_LIT &&
(1 == (gtm_utf8_mode ?
MV_FORCE_LEN(delim_mval) : delim_mval->str.len)))
{ /* Single char delimiter for set $piece */
UNICODE_ONLY(
if (gtm_utf8_mode)
{ /* We have a supposed single char delimiter but it
* must be a valid utf8 char to be used by
* op_setp1() and MV_FORCE_LEN won't tell us that.
*/
valid_char = UTF8_VALID(delim_mval->str.addr,
(delim_mval->str.addr
+ delim_mval->str.len),
delimlen);
if (!valid_char && !badchar_inhibit)
UTF8_BADCHAR(0, delim_mval->str.addr,
(delim_mval->str.addr
+ delim_mval->str.len),
0, NULL);
}
);
if (valid_char || 1 == delim_mval->str.len)
{ /* This reference to a one character literal or a single
* byte invalid utf8 character that needs to be turned into
* an explict formated integer literal instead
*/
unichar.unichar_val = 0;
if (!gtm_utf8_mode)
{ /* Single byte delimiter */
assert(1 == delim_mval->str.len);
UNIX_ONLY(s->opcode = OC_SETZP1);
VMS_ONLY(s->opcode = OC_SETP1);
unichar.unibytes_val[0] = *delim_mval->str.addr;
}
UNICODE_ONLY(
else
{ /* Potentially multiple bytes in one int */
assert(SIZEOF(int) >= delim_mval->str.len);
memcpy(unichar.unibytes_val,
delim_mval->str.addr,
delim_mval->str.len);
s->opcode = OC_SETP1;
}
);
delimlit = (mint)unichar.unichar_val;
delimiter->operand[0] = put_ilit(delimlit);
delim1char = TRUE;
}
}
}
int m_zwrite(void)
{
int4 pcount; /* parameter count */
triple *ref,*ref1,*head,*last,*count;
opctype op;
oprtype name,limit;
mval mv;
mint code;
mint subscount;
char c;
bool pat;
error_def(ERR_VAREXPECTED);
error_def(ERR_RPARENMISSING);
error_def(ERR_ZWRSPONE);
error_def(ERR_COMMA);
subscount = 0;
count = 0;
pat = FALSE;
if (window_token == TK_CIRCUMFLEX)
{
advancewindow();
op = OC_GVZWRITE;
}
else
{ op = OC_LVZWRITE;
}
switch(window_token)
{
case TK_SPACE:
case TK_EOL:
if (op == OC_GVZWRITE)
{
stx_error(ERR_VAREXPECTED);
return FALSE;
}
else
{ op = OC_LVPATWRITE;
}
head = maketriple(op);
head->operand[0] = put_ilit((mint)3);
ref1 = newtriple(OC_PARAMETER);
head->operand[1] = put_tref(ref1);
ref1->operand[0] = put_ilit(0); /* shows not from zshow */
ref = newtriple(OC_PARAMETER);
ref1->operand[1] = put_tref(ref);
ref->operand[0] = put_str((char *)pat_everything,sizeof_pat_everything);
MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ;
ref->operand[1] = put_lit(&mv);
ins_triple(head);
return TRUE;
case TK_IDENT:
name = put_str(&window_ident.c[0],mid_len(&window_ident));
advancewindow();
break;
case TK_LPAREN:
if (op != OC_GVZWRITE) /* naked reference */
{
stx_error(ERR_VAREXPECTED);
return FALSE;
}
name = put_str(&window_ident.c[0], 0);
break;
case TK_ATSIGN:
if (!indirection(&name))
return FALSE;
if (op == OC_LVZWRITE && window_token != TK_LPAREN)
{
ref = maketriple(OC_COMMARG);
ref->operand[0] = name;
ref->operand[1] = put_ilit(indir_zwrite);
ins_triple(ref);
return TRUE;
}
ref = newtriple(OC_INDPAT);
ref->operand[0] = name;
name = put_tref(ref);
break;
case TK_QUESTION:
advancewindow();
source_column = last_source_column;
if (!compile_pattern(&name,FALSE))
return FALSE;
if (op == OC_LVZWRITE)
op = OC_LVPATWRITE;
pat = TRUE;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
head = maketriple(op);
last = newtriple(OC_PARAMETER);
head->operand[1] = put_tref(last);
pcount = 1;
if (op == OC_LVPATWRITE || op == OC_GVZWRITE)
{
pcount++;
last->operand[0] = put_ilit((op == OC_GVZWRITE ? pat : 0));
ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
last = ref;
if (op == OC_GVZWRITE)
{
pcount++;
count = last;
ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
last = ref;
}
}
last->operand[0] = name;
if (window_token != TK_LPAREN)
{
pcount++;
if (pat)
{
MV_FORCE_MVAL(&mv,ZWRITE_END) ;
}
else
{ subscount++ ;
MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ;
}
last->operand[1] = put_lit(&mv);
head->operand[0] = put_ilit(pcount);
if (count)
count->operand[0] = put_ilit(subscount);
ins_triple(head);
return TRUE;
}
advancewindow();
for(;;)
{
ref = newtriple(OC_PARAMETER);
last->operand[1] = put_tref(ref);
switch (window_token)
{
case TK_RPAREN:
dqdel(ref,exorder);
advancewindow();
MV_FORCE_MVAL(&mv,ZWRITE_END) ;
last->operand[1] = put_lit(&mv);
pcount++;
head->operand[0] = put_ilit((mint)pcount);
if (count)
count->operand[0] = put_ilit(subscount);
ins_triple(head);
return TRUE;
case TK_ASTERISK:
dqdel(ref,exorder);
advancewindow();
if (window_token != TK_RPAREN)
{
stx_error(ERR_RPARENMISSING);
return FALSE;
}
advancewindow();
MV_FORCE_MVAL(&mv,ZWRITE_ASTERISK) ;
last->operand[1] = put_lit(&mv);
pcount++;
subscount++;
head->operand[0] = put_ilit((mint)pcount);
if (count)
count->operand[0] = put_ilit(subscount);
ins_triple(head);
return TRUE;
case TK_QUESTION:
advancewindow();
source_column = last_source_column;
if (!compile_pattern(&limit,FALSE))
return FALSE;
if (window_token != TK_COMMA && window_token != TK_RPAREN)
{ stx_error(ERR_ZWRSPONE);
return FALSE;
}
if (window_token == TK_COMMA)
advancewindow();
subscount++;
MV_FORCE_MVAL(&mv,ZWRITE_PATTERN) ;
ref->operand[0] = put_lit(&mv);
pcount++;
ref1 = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(ref1);
ref1->operand[0] = limit;
last = ref1;
pcount++;
continue;
case TK_COLON:
if ((c = director_token) != TK_RPAREN)
{
if (c != TK_COMMA)
{
advancewindow();
MV_FORCE_MVAL(&mv,ZWRITE_UPPER) ;
ref->operand[0] = put_lit(&mv);
pcount++;
subscount++;
break;
}
advancewindow();
}
/* caution: fall through */
case TK_COMMA:
advancewindow();
MV_FORCE_MVAL(&mv,ZWRITE_ALL) ;
ref->operand[0] = put_lit(&mv);
pcount++;
subscount++;
last = ref;
continue;
default:
if (!expr(&limit))
return FALSE;
subscount++;
last = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(last);
last->operand[0] = limit;
pcount++;
if ((c = window_token) == TK_COLON)
{
code = ZWRITE_LOWER;
advancewindow();
c = window_token;
}
else
code = ZWRITE_VAL;
switch (c)
{
case TK_COMMA:
advancewindow();
/* caution: fall through */
case TK_RPAREN:
MV_FORCE_MVAL(&mv,code) ;
ref->operand[0] = put_lit(&mv);
pcount++;
continue;
default:
if (code == ZWRITE_VAL)
{
stx_error(ERR_COMMA);
return FALSE;
}
MV_FORCE_MVAL(&mv,ZWRITE_BOTH) ;
ref->operand[0] = put_lit(&mv);
pcount++;
ref = last;
break;
}
break;
}
if (!expr(&limit))
return FALSE;
last = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(last);
last->operand[0] = limit;
pcount++;
if (window_token == TK_COMMA)
{
advancewindow();
}
}
}
void bx_boolop(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr)
{
boolean_t expr_fini;
oprtype *adj_addr, *i, *p;
tbp *tripbp;
triple *ref0, *ref1, *ref2, *t0, *t1;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(((1 & sense) == sense) && ((1 & jmp_to_next) == jmp_to_next) && ((1 & jmp_type_one) == jmp_type_one));
assert((TRIP_REF == t->operand[0].oprclass) && (TRIP_REF == t->operand[1].oprclass));
if (jmp_to_next)
{
p = (oprtype *)mcalloc(SIZEOF(oprtype));
*p = put_tjmp(t);
} else
p = addr;
if (GTM_BOOL == TREF(gtm_fullbool) || !TREF(saw_side_effect))
{ /* nice simple short circuit */
assert(NULL == TREF(boolchain_ptr));
bx_tail(t->operand[0].oprval.tref, jmp_type_one, p);
bx_tail(t->operand[1].oprval.tref, sense, addr);
t->opcode = OC_NOOP;
t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
return;
}
/* got a side effect and don't want them short circuited */
/* This code violates info hiding big-time and relies on the original technique of setting up a jump ladder
* then it changes the jumps into stotemps and creates a new ladder using the saved evaluations
* for the relocated jumps to use for controlling conditional transfers, When the stotemps reference mvals,
* they are optimized away when possible. The most interesting part is getting the addresses for the new jump
* operands (targets) - see comment below. In theory we could turn this technique on and off around each side effect,
* but that's even more complicated, requiring additional instructions, and we don't predict the typical boolean
* expression has enough subexpressions to justify the extra trouble, although the potential pay-back would be to
* avoid unnecessary global references - again, not expecting that many in a typical boolean expresion.
*/
assert(TREF(shift_side_effects));
if (expr_fini = (NULL == TREF(boolchain_ptr))) /* NOTE assignment */
{ /* initialize work on boolean section of the AST */
TREF(boolchain_ptr) = &(TREF(boolchain));
dqinit(TREF(boolchain_ptr), exorder);
t0 = t->exorder.fl;
if (NULL == TREF(bool_targ_ptr))
{ /* first time - set up anchor */
TREF(bool_targ_ptr) = &(TREF(bool_targ_anchor)); /* mcalloc won't persist over multiple complies */
dqinit(TREF(bool_targ_ptr), que);
} else /* queue should be empty */
assert((TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.fl)
&& (TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.bl));
/* ex_tail wraps bools that produce a value with OC_BOOLINIT (clr) and OC_BOOLFINI (set) */
assert((OC_BOOLFINI != t0->opcode)
|| ((OC_COMVAL == t0->exorder.fl->opcode) && (TRIP_REF == t0->operand[0].oprclass)));
}
for (i = t->operand; i < ARRAYTOP(t->operand); i++)
{
assert(NULL != TREF(boolchain_ptr));
t1 = i->oprval.tref;
if (&(t->operand[0]) == i)
bx_tail(t1, jmp_type_one, p); /* do normal transform */
else
{ /* operand[1] */
bx_tail(t1, sense, addr); /* do normal transform */
if (!expr_fini)
break; /* only need to relocate last operand[1] */
}
if (OC_NOOP == t1->opcode)
{ /* the technique of sprinkling noops means fishing around for the actual instruction */
do
{
t1 = t1->exorder.bl;
assert(TREF(curtchain) != t1->exorder.bl);
} while (OC_NOOP == t1->opcode);
if ((oc_tab[t1->opcode].octype & OCT_JUMP) && (OC_JMPTSET != t1->opcode) && (OC_JMPTCLR != t1->opcode))
t1 = t1->exorder.bl;
if (OC_NOOP == t1->opcode)
{
for (t1 = i->oprval.tref; OC_NOOP == t1->opcode; t1 = t1->exorder.fl)
assert(TREF(curtchain) != t1->exorder.fl);
}
}
assert(OC_NOOP != t1->opcode);
assert((oc_tab[t1->exorder.fl->opcode].octype & OCT_JUMP)
||(OC_JMPTSET != t1->exorder.fl->opcode) || (OC_JMPTCLR != t1->exorder.fl->opcode));
ref0 = maketriple(t1->opcode); /* copy operation for place in new ladder */
ref1 = (TREF(boolchain_ptr))->exorder.bl; /* common setup for above op insert */
switch (t1->opcode)
{ /* time to subvert original jump ladder entry */
case OC_COBOOL:
/* insert COBOOL and copy of following JMP in boolchain; overlay them with STOTEMP and NOOP */
assert(TRIP_REF == t1->operand[0].oprclass);
dqins(ref1, exorder, ref0);
if (oc_tab[t1->operand[0].oprval.tref->opcode].octype & OCT_MVAL)
{ /* do we need a STOTEMP? */
switch (t1->operand[0].oprval.tref->opcode)
{
case OC_INDGLVN: /* indirect actions not happy without STOTEMP */
case OC_INDNAME:
case OC_VAR: /* variable could change so must save it */
t1->opcode = OC_STOTEMP;
ref0->operand[0] = put_tref(t1);/* new COBOOL points to this OC_STOTEMP */
break;
default: /* else no temporary if it's mval */
ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
t1->opcode = OC_NOOP;
t1->operand[0].oprclass = NOCLASS;
}
} else
{ /* make it an mval instead of COBOOL now */
t1->opcode = OC_COMVAL;
ref0->operand[0] = put_tref(t1); /* new COBOOL points to this OC_COMVAL */
}
t1 = t1->exorder.fl;
ref0 = maketriple(t1->opcode); /* create new jmp on result of coerce */
ref0->operand[0] = t1->operand[0];
t1->opcode = OC_NOOP; /* wipe out original jmp */
t1->operand[0].oprclass = NOCLASS;
break;
case OC_CONTAIN:
case OC_EQU:
case OC_FOLLOW:
case OC_NUMCMP:
case OC_PATTERN:
case OC_SORTS_AFTER:
/* insert copies of orig OC and following JMP in boolchain & overly originals with STOTEMPs */
assert(TRIP_REF == t1->operand[0].oprclass);
assert(TRIP_REF == t1->operand[1].oprclass);
dqins(ref1, exorder, ref0);
if (OC_VAR == t1->operand[0].oprval.tref->opcode)
{ /* VAR could change so must save it */
t1->opcode = OC_STOTEMP; /* overlay the original op with a STOTEMP */
ref0->operand[0] = put_tref(t1); /* new op points to thi STOTEMP */
} else
{ /* no need for a temporary unless it's a VAR */
ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
t1->opcode = OC_NOOP;
}
ref1 = t1;
t1 = t1->exorder.fl;
ref2 = maketriple(t1->opcode); /* copy jmp */
ref2->operand[0] = t1->operand[0];
if (OC_VAR == ref1->operand[1].oprval.tref->opcode)
{ /* VAR could change so must save it */
ref0->operand[1] = put_tref(t1); /* new op points to STOTEMP overlaying the jmp */
t1->operand[0] = ref1->operand[1];
t1->opcode = OC_STOTEMP; /* overlay jmp with 2nd STOTEMP */
} else
{ /* no need for a temporary unless it's a VAR */
ref0->operand[1] = put_tref(ref1->operand[1].oprval.tref);
t1->opcode = OC_NOOP;
t1->operand[0].oprclass = NOCLASS;
}
if (OC_NOOP == ref1->opcode) /* does op[0] need cleanup? */
ref1->operand[0].oprclass = ref1->operand[1].oprclass = NOCLASS;
ref0 = ref2;
break;
case OC_JMPTSET:
case OC_JMPTCLR:
/* move copy of jmp to boolchain and NOOP it */
ref0->operand[0] = t1->operand[0]; /* new jmpt gets old target */
ref2 = maketriple(OC_NOOP); /* insert a NOOP in new chain inplace of COBOOL */
dqins(ref1, exorder, ref2);
t1->opcode = OC_NOOP; /* wipe out original jmp */
t1->operand[0].oprclass = NOCLASS;
break;
default:
assertpro(FALSE);
}
assert((OC_STOTEMP == t1->opcode) || (OC_NOOP == t1->opcode) || (OC_COMVAL == t1->opcode));
assert(oc_tab[ref0->opcode].octype & OCT_JUMP);
ref1 = (TREF(boolchain_ptr))->exorder.bl;
dqins(ref1, exorder, ref0); /* common insert for new jmp */
}
assert(oc_tab[t->opcode].octype & OCT_BOOL);
t->opcode = OC_NOOP; /* wipe out the original boolean op */
t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
tripbp = &t->jmplist; /* borrow jmplist to track jmp targets */
assert(NULL == tripbp->bpt);
assert((tripbp == tripbp->que.fl) && (tripbp == tripbp->que.bl));
tripbp->bpt = jmp_to_next ? (TREF(boolchain_ptr))->exorder.bl : ref0; /* point op triple at op[1] position or op[0] */
dqins(TREF(bool_targ_ptr), que, tripbp); /* queue jmplist for clean-up */
if (!expr_fini)
return;
/* time to deal with new jump ladder */
assert(NULL != TREF(boolchain_ptr));
assert(NULL != TREF(bool_targ_ptr));
assert(TREF(bool_targ_ptr) != (TREF(bool_targ_ptr))->que.fl);
assert(t0->exorder.bl == t);
assert(t0 == t->exorder.fl);
dqadd(t, TREF(boolchain_ptr), exorder); /* insert the new jump ladder */
ref0 = (TREF(boolchain_ptr))->exorder.bl->exorder.fl;
t0 = t->exorder.fl;
if (ref0 == TREF(curtchain))
{ /* add a safe target */
newtriple(OC_NOOP);
ref0 = (TREF(curtchain))->exorder.bl;
}
assert((OC_COBOOL == t0->opcode) ||(OC_JMPTSET != t0->opcode) || (OC_JMPTCLR != t0->opcode)) ;
t0 = t0->exorder.fl;
assert(oc_tab[t0->opcode].octype & OCT_JUMP);
for (; (t0 != ref0) && oc_tab[t0->opcode].octype & OCT_JUMP; t0 = t0->exorder.fl)
{ /* process replacement jmps */
adj_addr = &t0->operand[0];
assert(INDR_REF == adj_addr->oprclass);
if (NULL != (t1 = (adj_addr = adj_addr->oprval.indr)->oprval.tref))
{ /* need to adjust target; NOTE assignments above */
if (OC_BOOLFINI != t1->opcode)
{ /* not past the end of the new chain */
assert(TJMP_REF == adj_addr->oprclass);
if ((t == t1) || (t1 == ref0))
ref1 = ref0; /* adjust to end of boolean expression */
else
{ /* old target should have jmplist entry */
/* from the jmp jmplisted in the old target we move past the next
* test (or NOOP) and jmp which correspond to the old target and pick
* the subsequent test (or NOOP) and jmp which correspond to those that originally followed
* the logic after the old target and are therefore the appropriate new target for this jmp
*/
assert(OC_NOOP == t1->opcode);
assert(&(t1->jmplist) != t1->jmplist.que.fl);
assert(NULL != t1->jmplist.bpt);
assert(oc_tab[t1->jmplist.bpt->opcode].octype & OCT_JUMP);
ref1 = t1->jmplist.bpt->exorder.fl;
assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_NOOP == ref1->opcode));
assert(oc_tab[ref1->exorder.fl->opcode].octype & OCT_JUMP);
ref1 = ref1->exorder.fl->exorder.fl;
assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_BOOLFINI == ref1->opcode)
|| ((OC_NOOP == ref1->opcode) && ((OC_JMPTCLR == ref1->exorder.fl->opcode)
|| (OC_JMPTSET == ref1->exorder.fl->opcode)
|| (TREF(curtchain) == ref1->exorder.fl))));
}
t0->operand[0] = put_tjmp(ref1); /* no indrection simplifies later interations */
}
}
t0 = t0->exorder.fl;
if ((OC_BOOLFINI == t0->opcode) || (TREF(curtchain) == t0->exorder.fl))
break;
assert((oc_tab[t0->opcode].octype & OCT_BOOL)
|| (OC_JMPTSET == t0->exorder.fl->opcode) || (OC_JMPTCLR == t0->exorder.fl->opcode));
}
dqloop(TREF(bool_targ_ptr), que, tripbp) /* clean up borrowed jmplist entries */
{
dqdel(tripbp, que);
tripbp->bpt = NULL;
}
int m_if(void)
{
triple *ref0, *ref1, *ref2, *jmpref, ifpos_in_chain, *triptr;
oprtype x, y, *ta_opr;
bool first_time, t_set, is_commarg;
typedef struct jmpchntype
{ struct
{ struct jmpchntype *fl,*bl;
}link;
triple *jmptrip;
}jmpchn;
jmpchn *jmpchain,*nxtjmp;
error_def(ERR_SPOREOL);
error_def(ERR_INDEXTRACHARS);
ifpos_in_chain = pos_in_chain;
jmpchain = (jmpchn*) mcalloc(sizeof(jmpchn));
dqinit(jmpchain,link);
if (window_token == TK_EOL)
return TRUE;
is_commarg = last_source_column == 1;
x = for_end_of_scope(0);
assert(x.oprclass == INDR_REF);
if (window_token == TK_SPACE)
{ jmpref = newtriple(OC_JMPTCLR);
jmpref->operand[0] = x;
nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
nxtjmp->jmptrip = jmpref;
dqins(jmpchain,link,nxtjmp);
}
else
{
first_time = TRUE;
for (;;)
{
ta_opr = (oprtype *) mcalloc(sizeof(oprtype));
if (!bool_expr((bool) TRUE, ta_opr))
return FALSE;
if ((ref0 = curtchain->exorder.bl)->opcode == OC_JMPNEQ
&& (ref1 = ref0->exorder.bl)->opcode == OC_COBOOL
&& (ref2 = ref1->exorder.bl)->opcode == OC_INDGLVN)
{
dqdel(ref0,exorder);
ref1->opcode = OC_JMPTSET;
ref1->operand[0] = put_indr(ta_opr);
ref2->opcode = OC_COMMARG;
ref2->operand[1] = put_ilit((mint) indir_if);
}
t_set = curtchain->exorder.bl->opcode == OC_JMPTSET;
if (!t_set)
newtriple(OC_CLRTEST);
if (expr_start != expr_start_orig)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
}
jmpref = newtriple(OC_JMP);
jmpref->operand[0] = x;
nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
nxtjmp->jmptrip = jmpref;
dqins(jmpchain,link,nxtjmp);
tnxtarg(ta_opr);
if (first_time)
{
if (!t_set)
newtriple(OC_SETTEST);
if (expr_start != expr_start_orig)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
}
first_time = FALSE;
}
if (window_token != TK_COMMA)
break;
advancewindow();
}
}
if (is_commarg)
{
if (window_token != TK_EOL)
{
stx_error(ERR_INDEXTRACHARS);
return FALSE;
}
return TRUE;
}
if (window_token != TK_EOL && window_token != TK_SPACE)
{
stx_error(ERR_SPOREOL);
return FALSE;
}
if (!linetail())
{ tnxtarg(&x);
dqloop(jmpchain,link,nxtjmp)
{ ref1 = nxtjmp->jmptrip;
ref1->operand[0] = x;
}
int bool_expr(boolean_t sense, oprtype *addr)
/*
* invoked to resolve expresions that are by definition coerced to Boolean, which include
* IF arguments, $SELECT() arguments, and postconditionals for both commands and arguments
* IF is the only one that comes in with the "TRUE" sense
* *addr winds up as an pointer to a jump operand, which the caller fills in
*/
{
boolean_t is_com, tv;
uint4 bexprs;
opctype c;
oprtype x;
triple *bitrip, *t, *t0, *t1, *t2;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
INCREMENT_EXPR_DEPTH;
if (!eval_expr(&x))
{
DECREMENT_EXPR_DEPTH;
return FALSE;
}
UNARY_TAIL(&x);
if (OC_LIT == (x.oprval.tref)->opcode)
{ /* if its just a literal don't waste time */
DECREMENT_EXPR_DEPTH;
return TRUE;
}
assert(TRIP_REF == x.oprclass);
coerce(&x, OCT_BOOL);
t = x.oprval.tref;
for (t1 = t; ; t1 = t2)
{
assert(TRIP_REF == t1->operand[0].oprclass);
t2 = t1->operand[0].oprval.tref;
if (!(oc_tab[t2->opcode].octype & OCT_BOOL))
break;
}
if (OC_INDGLVN == t2->opcode)
t1 = t2; /* because of how we process indirection, can't insert a NOOP between COBOOL and INDGLGN */
bitrip = maketriple(OC_BOOLINIT); /* a marker we'll delete later */
dqins(t1->exorder.bl, exorder, bitrip);
assert(TREF(curtchain) == t->exorder.fl);
(TREF(curtchain))->operand[0] = put_tref(bitrip);
bx_tail(t, sense, addr);
(TREF(curtchain))->operand[0].oprclass = NO_REF;
assert(t == x.oprval.tref);
DECREMENT_EXPR_DEPTH;
for (bexprs = 0, t0 = t; bitrip != t0; t0 = t0->exorder.bl)
{
if (OCT_JUMP & oc_tab[c = t0->opcode].octype) /* WARNING assignment */
{
switch (t0->opcode)
{
case OC_JMPFALSE:
case OC_JMPTRUE:
assert(INDR_REF == t0->operand[0].oprclass);
t0->opcode = (OC_JMPTRUE == t0->opcode) ? OC_NOOP : OC_JMP;
t0->operand[0].oprclass = (OC_NOOP == t0->opcode) ? NO_REF : INDR_REF;
if (!bexprs++)
t = t0;
break;
default:
bexprs += 2;
}
}
}
bitrip->opcode = OC_NOOP; /* ditch it after it served us */
if (1 == bexprs)
{ /* if there is just a one JMP TRUE / FALSE turn it into a literal */
assert((OC_NOOP == t->opcode) || (OC_JMP == t->opcode));
PUT_LITERAL_TRUTH((OC_NOOP == t->opcode) ^ sense, t);
t->opcode = OC_LIT;
} else if (!bexprs && (OC_COBOOL == t->opcode) && (OC_LIT == (t0 = t->operand[0].oprval.tref)->opcode)
&& ((OC_JMPEQU == t->exorder.fl->opcode) || (OC_JMPNEQ == t->exorder.fl->opcode)))
{ /* just one jump based on a literal, so resolve it */
t->opcode = OC_NOOP;
t->operand[0].oprclass = NO_REF;
t = t->exorder.fl;
dqdel(t, exorder);
unuse_literal(&t0->operand[0].oprval.mlit->v);
tv = (((0 == t0->operand[0].oprval.mlit->v.m[1]) ? OC_JMPNEQ : OC_JMPEQU) == t->opcode) ^ sense;
PUT_LITERAL_TRUTH(tv, t0);
}
return TRUE;
}
void bx_tail(triple *t, boolean_t sense, oprtype *addr)
/*
* triple *t; triple to be processed
*boolean_t sense; code to be generated is jmpt or jmpf
*oprtype *addr; address to jmp
*/
{
triple *ref;
oprtype *p;
assert((1 & sense) == sense);
assert(oc_tab[t->opcode].octype & OCT_BOOL);
assert(TRIP_REF == t->operand[0].oprclass);
assert((TRIP_REF == t->operand[1].oprclass) || (NOCLASS == t->operand[1].oprclass));
switch (t->opcode)
{
case OC_COBOOL:
ex_tail(&t->operand[0]);
if (OC_GETTRUTH == t->operand[0].oprval.tref->opcode)
{
dqdel(t->operand[0].oprval.tref, exorder);
t->opcode = sense ? OC_JMPTSET : OC_JMPTCLR;
t->operand[0] = put_indr(addr);
return;
}
ref = maketriple(sense ? OC_JMPNEQ : OC_JMPEQU);
ref->operand[0] = put_indr(addr);
dqins(t, exorder, ref);
return;
case OC_COM:
bx_tail(t->operand[0].oprval.tref, !sense, addr);
t->opcode = OC_NOOP;
t->operand[0].oprclass = 0;
return;
case OC_NEQU:
sense = !sense;
/* caution: fall through */
case OC_EQU:
bx_relop(t, OC_EQU, sense ? OC_JMPNEQ : OC_JMPEQU, addr);
break;
case OC_NPATTERN:
sense = !sense;
/* caution: fall through */
case OC_PATTERN:
bx_relop(t, OC_PATTERN, sense ? OC_JMPNEQ : OC_JMPEQU, addr);
break;
case OC_NFOLLOW:
sense = !sense;
/* caution: fall through */
case OC_FOLLOW:
bx_relop(t, OC_FOLLOW, sense ? OC_JMPGTR : OC_JMPLEQ, addr);
break;
case OC_NSORTS_AFTER:
sense = !sense;
/* caution: fall through */
case OC_SORTS_AFTER:
bx_relop(t, OC_SORTS_AFTER, sense ? OC_JMPGTR : OC_JMPLEQ, addr);
break;
case OC_NCONTAIN:
sense = !sense;
/* caution: fall through */
case OC_CONTAIN:
bx_relop(t, OC_CONTAIN, sense ? OC_JMPNEQ : OC_JMPEQU, addr);
break;
case OC_NGT:
sense = !sense;
/* caution: fall through */
case OC_GT:
bx_relop(t, OC_NUMCMP, sense ? OC_JMPGTR : OC_JMPLEQ, addr);
break;
case OC_NLT:
sense = !sense;
/* caution: fall through */
case OC_LT:
bx_relop(t, OC_NUMCMP, sense ? OC_JMPLSS : OC_JMPGEQ, addr);
break;
case OC_NAND:
sense = !sense;
/* caution: fall through */
case OC_AND:
bx_boolop(t, FALSE, sense, sense, addr);
return;
case OC_NOR:
sense = !sense;
/* caution: fall through */
case OC_OR:
bx_boolop(t, TRUE, !sense, sense, addr);
return;
default:
GTMASSERT;
}
for (p = t->operand ; p < ARRAYTOP(t->operand); p++)
if (TRIP_REF == p->oprclass)
ex_tail(p);
return;
}
