int f_zprevious(oprtype *a, opctype op)
{
triple *oldchain, *r;
save_se save_state;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
r = maketriple(op);
switch (TREF(window_token))
{
case TK_IDENT:
if (TK_LPAREN != TREF(director_token))
{
r->opcode = OC_FNLVPRVNAME;
r->operand[0] = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
ins_triple(r);
advancewindow();
break;
}
if (!lvn(&(r->operand[0]), OC_SRCHINDX, r))
return FALSE;
ins_triple(r);
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
r->opcode = OC_ZPREVIOUS;
ins_triple(r);
break;
case TK_ATSIGN:
if (SHIFT_SIDE_EFFECTS)
{
START_GVBIND_CHAIN(&save_state, oldchain);
if (!indirection(&(r->operand[0])))
{
setcurtchain(oldchain);
return FALSE;
}
r->operand[1] = put_ilit((mint)indir_fnzprevious);
ins_triple(r);
PLACE_GVBIND_CHAIN(&save_state, oldchain);
} else
{
if (!indirection(&(r->operand[0])))
return FALSE;
r->operand[1] = put_ilit((mint)indir_fnzprevious);
ins_triple(r);
}
r->opcode = OC_INDFUN;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
*a = put_tref(r);
return TRUE;
}
int f_data(oprtype *a, opctype op)
{
triple *oldchain, *r, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(OC_FNDATA == op || OC_FNZDATA == op);
r = maketriple(op);
switch (TREF(window_token))
{
case TK_IDENT:
if (!lvn(&(r->operand[0]), OC_SRCHINDX, 0))
return FALSE;
ins_triple(r);
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
r->opcode = OC_GVDATA;
ins_triple(r);
break;
case TK_ATSIGN:
TREF(saw_side_effect) = TREF(shift_side_effects);
if (TREF(shift_side_effects) && (GTM_BOOL == TREF(gtm_fullbool)))
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!indirection(&(r->operand[0])))
{
setcurtchain(oldchain);
return FALSE;
}
r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata));
ins_triple(r);
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
dqadd(TREF(expr_start), &tmpchain, exorder);
TREF(expr_start) = tmpchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
} else
{
if (!indirection(&(r->operand[0])))
return FALSE;
r->operand[1] = put_ilit((mint)(OC_FNDATA == op ? indir_fndata : indir_fnzdata));
ins_triple(r);
}
r->opcode = OC_INDFUN;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
*a = put_tref(r);
return TRUE;
}
int m_zwithdraw(void)
{
oprtype tmparg;
triple *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
switch (TREF(window_token))
{
case TK_IDENT:
if (!lvn(&tmparg,OC_SRCHINDX,0))
return FALSE;
ref = newtriple(OC_LVZWITHDRAW);
ref->operand[0] = tmparg;
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
ref = newtriple(OC_GVZWITHDRAW);
break;
case TK_ATSIGN:
if (!indirection(&tmparg))
return FALSE;
ref = maketriple(OC_COMMARG);
ref->operand[0] = tmparg;
ref->operand[1] = put_ilit((mint) indir_zwithdraw);
ins_triple(ref);
return TRUE;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
return TRUE;
}
int m_ztrigger(void)
{
# ifdef GTM_TRIGGER
oprtype tmparg;
triple *ref;
error_def(ERR_GBLEXPECTED);
switch (window_token)
{
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
ref = newtriple(OC_ZTRIGGER);
break;
case TK_ATSIGN:
if (!indirection(&tmparg))
return FALSE;
ref = maketriple(OC_COMMARG);
ref->operand[0] = tmparg;
ref->operand[1] = put_ilit((mint)indir_ztrigger);
ins_triple(ref);
return TRUE;
default:
stx_error(ERR_GBLEXPECTED);
return FALSE;
}
return TRUE;
# else
return FALSE;
# endif
}
int f_get1(oprtype *a, opctype op)
{
triple *oldchain, *r;
save_se save_state;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
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:
r->opcode = OC_FNGET1;
if (!lvn(&r->operand[0], OC_SRCHINDX, 0))
return FALSE;
break;
case TK_CIRCUMFLEX:
r->opcode = OC_FNGVGET1;
if (!gvn())
return FALSE;
break;
case TK_ATSIGN:
r->opcode = OC_INDFUN;
r->operand[1] = put_ilit((mint)indir_get);
if (SHIFT_SIDE_EFFECTS)
{ /* with short-circuited booleans move indirect processing to expr_start */
START_GVBIND_CHAIN(&save_state, oldchain);
if (!indirection(&r->operand[0]))
{
setcurtchain(oldchain);
return FALSE;
}
ins_triple(r);
PLACE_GVBIND_CHAIN(&save_state, oldchain);
*a = put_tref(r);
return TRUE;
}
if (!indirection(&(r->operand[0])))
return FALSE;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
void DataStruct::print( QString& out, const QString& indent, const QString& newitem, int level, int maxElemSize) const
{
if (atomic())
{
out.append("'");
if (maxElemSize >= 0)
{
out.append( shortenDebugMessageArgument( value().toString(), maxElemSize));
}
else
{
out.append( value().toString());
}
out.append("'");
}
else if (array())
{
int ii = 1;
for (; ii<=m_size; ++ii)
{
if (ii>1) out.append( ", ");
m_data.ref[ ii].print( out, indent, newitem, level+1, maxElemSize);
}
}
else if (indirection())
{
// ... unexpanded indirection is ignored
}
else if (m_description)
{
DataStructDescription::const_iterator di = m_description->begin(), de = m_description->end();
DataStruct::const_iterator ei = structbegin();
for (int idx=0; di != de; ++di,++ei)
{
if (ei->initialized())
{
if (idx++)
{
out.append( ";");
print_newitem( out, indent, newitem, level);
}
out.append( di->name);
if (di->array()) out.append( "[]");
if (di->attribute())
{
out.append( "=");
out.append( ei->toString( maxElemSize));
}
else
{
out.append( "{");
ei->print( out, indent, newitem, level+1, maxElemSize);
out.append( "}");
}
}
}
}
}
int f_name(oprtype *a, opctype op)
{
boolean_t gbl;
oprtype *depth;
short int column;
triple *r, *s;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
r = maketriple(op);
gbl = FALSE;
switch (TREF(window_token))
{
case TK_CIRCUMFLEX:
gbl = TRUE;
advancewindow();
/* caution fall through */
case TK_IDENT:
if (!name_glvn(gbl, &r->operand[1]))
return FALSE;
depth = &r->operand[0];
break;
case TK_ATSIGN:
r->opcode = OC_INDFNNAME2; /* chomps extra subscripts of resulting string */
s = maketriple(OC_INDFNNAME);
if (!indirection(&(s->operand[0])))
return FALSE;
s->operand[1] = put_ilit(MAX_LVSUBSCRIPTS + 1); /* first, get all the subscripts. r will chomp them */
coerce(&s->operand[1], OCT_MVAL);
ins_triple(s);
depth = &r->operand[0];
r->operand[1] = put_tref(s);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
/* allow for optional default value */
if (TK_COMMA != TREF(window_token))
{
*depth = put_ilit(MAX_LVSUBSCRIPTS + 1); /* default to maximum number of subscripts allowed by law */
/* ideally this should be MAX(MAX_LVSUBSCRIPTS, MAX_GVSUBSCRIPTS) but they are the same so take the easy path */
assert(MAX_LVSUBSCRIPTS == MAX_GVSUBSCRIPTS); /* add assert to ensure our assumption is valid */
} else
{
DISABLE_SIDE_EFFECT_AT_DEPTH; /* doing this here let's us know specifically if direction had SE threat */
advancewindow();
column = source_column;
if (EXPR_FAIL == expr(depth, MUMPS_STR))
return FALSE;
if (!run_time && (OC_INDFNNAME2 == r->opcode) && (SE_WARN == TREF(side_effect_handling)))
ISSUE_SIDEEFFECTEVAL_WARNING(column - 1);
}
coerce(depth, OCT_MVAL);
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
void op_indrzshow(mval *s1,mval *s2)
{
mstr object;
bool rval;
oprtype v;
triple *src, *r, *outtype, *lvar;
error_def(ERR_VAREXPECTED);
error_def(ERR_INDMAXNEST);
comp_init(&s2->str);
src = maketriple(OC_IGETSRC);
ins_triple(src);
switch(window_token)
{
case TK_CIRCUMFLEX:
if (rval = gvn())
{ r = maketriple(OC_ZSHOW);
outtype = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(outtype);
r->operand[0] = put_tref(src);
outtype->operand[0] = put_ilit(ZSHOW_GLOBAL);
ins_triple(r);
}
break;
case TK_IDENT:
if (rval = lvn(&v, OC_PUTINDX, 0))
{ r = maketriple(OC_ZSHOWLOC);
outtype = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(outtype);
r->operand[0] = put_tref(src);
lvar = newtriple(OC_PARAMETER);
outtype->operand[1] = put_tref(lvar);
lvar->operand[0] = v;
outtype->operand[0] = put_ilit(ZSHOW_LOCAL);
ins_triple(r);
}
break;
case TK_ATSIGN:
if (rval = indirection(&v))
{ r = newtriple(OC_INDRZSHOW);
r->operand[0] = put_tref(src);
r->operand[1] = v;
}
break;
default:
stx_error(ERR_VAREXPECTED);
break;
}
if (comp_fini(rval, &object, OC_RET, 0, s2->str.len))
{ cache_put(indir_zshow, &s2->str, &object);
*ind_source_sp++ = s1;
if (ind_source_sp >= ind_source_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
}
return;
}
void op_indlvarg(mval *v, mval *dst)
{
bool rval;
mstr *obj, object;
oprtype x;
triple *ref;
icode_str indir_src;
error_def(ERR_INDMAXNEST);
error_def(ERR_VAREXPECTED);
MV_FORCE_STR(v);
if (v->str.len < 1)
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
if (valid_mname(&v->str))
{
*dst = *v;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
return;
}
if (*v->str.addr == '@')
{
indir_src.str = v->str;
indir_src.code = indir_lvarg;
if (NULL == (obj = cache_get(&indir_src)))
{
object.addr = v->str.addr;
object.len = v->str.len;
comp_init(&object);
if (rval = indirection(&x))
{
ref = newtriple(OC_INDLVARG);
ref->operand[0] = x;
x = put_tref(ref);
}
if (comp_fini(rval, &object, OC_IRETMVAL, &x, object.len))
{
indir_src.str.addr = v->str.addr;
cache_put(&indir_src, &object);
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(&object);
return;
}
} else
{
*ind_result_sp++ = dst;
if (ind_result_sp >= ind_result_top)
rts_error(VARLSTCNT(1) ERR_INDMAXNEST);
comp_indr(obj);
return;
}
}
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
}
void op_indlvarg(mval *v, mval *dst)
{
icode_str indir_src;
int rval;
mstr *obj, object;
oprtype x;
triple *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (TREF(ind_result_sp) >= TREF(ind_result_top))
rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp */
MV_FORCE_STR(v);
if (v->str.len < 1)
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
if (valid_mname(&v->str))
{
*dst = *v;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
return;
}
if (*v->str.addr != '@')
rts_error(VARLSTCNT(1) ERR_VAREXPECTED);
indir_src.str = v->str;
indir_src.code = indir_lvarg;
if (NULL == (obj = cache_get(&indir_src)))
{
obj = &object;
obj->addr = v->str.addr;
obj->len = v->str.len;
comp_init(obj);
if (EXPR_FAIL != (rval = indirection(&x))) /* NOTE assignment */
{
ref = newtriple(OC_INDLVARG);
ref->operand[0] = x;
x = put_tref(ref);
}
if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &x, obj->len))
return;
indir_src.str.addr = v->str.addr;
cache_put(&indir_src, obj);
/* Fall into code activation below */
}
*(TREF(ind_result_sp))++ = dst; /* Where to store return value */
comp_indr(obj);
return;
}
void KdCluster::leafWriteGroup(KdTreeNode *node, const BoundingBox & box)
{
const unsigned num = node->getNumPrims();
if(num < 1) return;
m_groupGeometries[m_currentGroup] = new GeometryArray;
GeometryArray * curGrp = m_groupGeometries[m_currentGroup];
curGrp->create(num);
unsigned start = node->getPrimStart();
sdb::VectorArray<Primitive> &indir = indirection();
//sdb::VectorArray<Primitive> &prims = primitives();
int igeom, icomponent;
unsigned igroup = 0;
for(unsigned i = 0; i < num; i++) {
//unsigned *iprim = indir[start + i];
//Primitive * prim = prims.get(*iprim);
Primitive * prim = indir[start + i];
prim->getGeometryComponent(igeom, icomponent);
Geometry * geo = m_stream.geometry(igeom);
if(geo->type() == TGeometryArray) {
GeometryArray * ga = (GeometryArray *)geo;
Geometry * comp = ga->geometry(icomponent);
BoundingBox comb = ga->calculateBBox(icomponent);
// do not add straddling geo
if(comb.getMax(0) <= box.getMax(0) &&
comb.getMax(1) <= box.getMax(1) &&
comb.getMax(2) <= box.getMax(2))
{
curGrp->setGeometry(comp, igroup);
igroup++;
}
}
else {
std::cout<<" grouping only works with geometry arry.";
}
//indir.next();
}
curGrp->setNumGeometries(igroup);
m_nodeGroupInd[node] = m_currentGroup;
m_currentGroup++;
}
int m_zdeallocate(void)
{
oprtype indopr;
triple *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
newtriple(OC_LKINIT);
switch(TREF(window_token))
{
case TK_EOL:
case TK_SPACE:
break;
case TK_ATSIGN:
if (!indirection(&indopr))
return FALSE;
ref = newtriple(OC_COMMARG);
ref->operand[0] = indopr;
ref->operand[1] = put_ilit((mint)indir_zdeallocate);
return TRUE;
break;
case TK_LPAREN:
do
{
advancewindow();
if (EXPR_FAIL == nref())
return FALSE;
} while (TK_COMMA == TREF(window_token));
if (TK_RPAREN != TREF(window_token))
{
stx_error(ERR_RPARENMISSING);
return FALSE;
}
advancewindow();
break;
default:
if (EXPR_FAIL == nref())
return FALSE;
break;
}
ref = newtriple(OC_ZDEALLOCATE);
ref->operand[0] = put_ilit(NO_M_TIMEOUT);
return EXPR_GOOD;
}
void op_indlvadr(mval *target)
{
error_def(ERR_VAREXPECTED);
bool rval;
mstr object, *obj;
oprtype v;
triple *s;
MV_FORCE_STR(target);
if (!(obj = cache_get(indir_lvadr, &target->str)))
{
comp_init(&target->str);
switch (window_token)
{
case TK_IDENT:
rval = lvn(&v, OC_PUTINDX, 0);
if (comp_fini(rval, &object, OC_IRETMVAD, &v, target->str.len))
{ cache_put(indir_lvadr, &target->str, &object);
comp_indr(&object);
}
break;
case TK_ATSIGN:
if (rval = indirection(&v))
{
s = newtriple(OC_INDLVADR);
s->operand[0] = v;
v = put_tref(s);
if (comp_fini(rval, &object, OC_IRETMVAD, &v, target->str.len))
{ cache_put(indir_lvadr, &target->str, &object);
comp_indr(&object);
}
}
break;
default:
stx_error(ERR_VAREXPECTED);
break;
}
}
else
{
comp_indr(obj);
}
}
void op_inddevparms(mval *devpsrc, int4 ok_iop_parms, mval *devpiopl)
{
int rval;
icode_str indir_src;
mstr *obj, object;
oprtype devpopr, plist, getdst;
triple *indref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
MV_FORCE_STR(devpsrc);
indir_src.str = devpsrc->str;
indir_src.code = indir_devparms;
if (NULL == (obj = cache_get(&indir_src))) /* NOTE assignment */
{ /* No cached version, compile it now */
obj = &object;
comp_init(&devpsrc->str, &getdst);
if (TK_ATSIGN == TREF(window_token))
{ /* For the indirection-obsessive */
if (EXPR_FAIL != (rval = indirection(&devpopr))) /* NOTE assignment */
{
indref = newtriple(OC_INDDEVPARMS);
indref->operand[0] = devpopr;
indref->operand[1] = put_ilit(ok_iop_parms);
plist = put_tref(indref);
}
} else /* We have the parm string to process now */
rval = deviceparameters(&plist, ok_iop_parms);
if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &plist, &getdst, devpsrc->str.len))
return;
indir_src.str.addr = devpsrc->str.addr;
cache_put(&indir_src, obj);
/* Fall into code activation below */
}
TREF(ind_result) = devpiopl; /* Where to store return value */
comp_indr(obj);
return;
}
bool KdIntersection::leafIntersectBox(KdTreeNode *node, const BoundingBox & box)
{
const unsigned num = node->getNumPrims();
if(num < 1) return false;
if(!box.intersect(m_testBox)) return false;
unsigned start = node->getPrimStart();
IndexArray &indir = indirection();
PrimitiveArray &prims = primitives();
indir.setIndex(start);
for(unsigned i = 0; i < num; i++) {
unsigned *iprim = indir.asIndex();
Primitive * prim = prims.asPrimitive(*iprim);
Geometry * geo = prim->getGeometry();
unsigned icomponent = prim->getComponentIndex();
if(geo->intersectBox(icomponent, m_testBox)) return true;
indir.next();
}
return false;
}
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 m_for(void)
{
unsigned int arg_cnt, arg_index, for_stack_level;
oprtype arg_eval_addr[MAX_FORARGS], increment[MAX_FORARGS], terminate[MAX_FORARGS],
arg_next_addr, arg_value, dummy, control_variable,
*iteration_start_addr, iteration_start_addr_indr, *not_even_once_addr;
triple *eval_next_addr[MAX_FORARGS], *control_ref,
*forchk1opc, forpos_in_chain, *init_ref, *ref, *step_ref, *term_ref, *var_ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
forpos_in_chain = TREF(pos_in_chain);
FOR_PUSH();
if (TK_SPACE == TREF(window_token))
{ /* "argumentless" form */
FOR_END_OF_SCOPE(1, dummy);
ref = newtriple(OC_FORCHK1);
if (!linetail())
{
TREF(pos_in_chain) = forpos_in_chain;
assert(TREF(source_error_found));
stx_error(TREF(source_error_found));
FOR_POP(BLOWN_FOR);
return FALSE;
}
SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */
newtriple(OC_JMP)->operand[0] = put_tjmp(ref); /* transfer back to just before the begining of the body */
FOR_POP(GOOD_FOR); /* and pop the array */
return TRUE;
}
for_stack_level = (TREF(for_stack_ptr) - TADR(for_stack));
init_ref = newtriple(OC_FORNESTLVL);
init_ref->operand[0] = put_ilit(for_stack_level);
if (TK_ATSIGN == TREF(window_token))
{
if (!indirection(&control_variable))
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
ref = newtriple(OC_INDLVADR);
ref->operand[0] = control_variable;
control_variable = put_tref(ref);
control_ref = NULL;
} else
{
/* The following relies on the fact that lvn() always generates an OC_VAR triple first */
control_ref = (TREF(curtchain))->exorder.bl;
if (!lvn(&control_variable, OC_SAVPUTINDX, NULL))
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(OC_VAR == control_ref->exorder.fl->opcode);
assert(MVAR_REF == control_ref->exorder.fl->operand[0].oprclass);
}
if (TK_EQUAL != TREF(window_token))
{
stx_error(ERR_EQUAL);
FOR_POP(BLOWN_FOR);
return FALSE;
}
newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* make sure optimizer doesn't ditch control_variable */
FOR_END_OF_SCOPE(1, dummy);
assert((0 < for_stack_level) && (MAX_FOR_STACK >= for_stack_level));
if ((OC_SAVPUTINDX == control_variable.oprval.tref->opcode) || (OC_INDLVADR == control_variable.oprval.tref->opcode))
TAREF1(for_temps, for_stack_level) = TRUE_WITH_INDX; /* most uses treat this as a boolean, but some need more */
else
init_ref->opcode = OC_NOOP;
iteration_start_addr = (oprtype *)mcalloc(SIZEOF(oprtype));
iteration_start_addr_indr = put_indr(iteration_start_addr);
arg_next_addr.oprclass = NOCLASS;
not_even_once_addr = NULL; /* used to skip processing where the initial control exceeds the termination */
for (arg_cnt = 0; ; ++arg_cnt)
{
if (MAX_FORARGS <= arg_cnt)
{
stx_error(ERR_MAXFORARGS);
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert((TK_COMMA == TREF(window_token)) || (TK_EQUAL == TREF(window_token)));
advancewindow();
tnxtarg(&arg_eval_addr[arg_cnt]); /* put location of this arg eval in arg_eval_addr array */
if (NULL != not_even_once_addr)
{
*not_even_once_addr = arg_eval_addr[arg_cnt];
not_even_once_addr = NULL;
}
if (EXPR_FAIL == expr(&arg_value, MUMPS_EXPR)) /* starting (possibly only) value */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == arg_value.oprclass);
if (TK_COLON != TREF(window_token))
{ /* list point value? */
increment[arg_cnt].oprclass = terminate[arg_cnt].oprclass = 0;
DEAL_WITH_DANGER(for_stack_level, control_variable, arg_value);
} else
{ /* stepping value */
init_ref = newtriple(OC_STOTEMP); /* tuck it in a temp undisturbed by coming evals */
init_ref->operand[0] = arg_value;
newtriple(OC_CONUM)->operand[0] = put_tref(init_ref); /* make start numeric */
advancewindow(); /* past the first colon */
var_ref = (TREF(curtchain))->exorder.bl;
if (EXPR_FAIL == expr(&increment[arg_cnt], MUMPS_EXPR)) /* pick up step */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == increment[arg_cnt].oprclass);
ref = increment[arg_cnt].oprval.tref;
if (OC_LIT != var_ref->exorder.fl->opcode)
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (OC_VAR == var_ref->exorder.fl->opcode)
{ /* The above relies on lvn() always generating an OC_VAR triple first - asserted earlier */
step_ref = newtriple(OC_STOTEMP);
step_ref->operand[0] = put_tref(ref);
increment[arg_cnt] = put_tref(step_ref);
}
}
if (TK_COLON != TREF(window_token))
{
DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
terminate[arg_cnt].oprclass = 0; /* no termination on iteration for this arg */
} else
{
advancewindow(); /* past the second colon */
var_ref = (TREF(curtchain))->exorder.bl;
if (EXPR_FAIL == expr(&terminate[arg_cnt], MUMPS_EXPR)) /* termination control value */
{
FOR_POP(BLOWN_FOR);
return FALSE;
}
assert(TRIP_REF == terminate[arg_cnt].oprclass);
ref = terminate[arg_cnt].oprval.tref;
if (OC_LIT != ref->opcode)
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (OC_VAR == var_ref->exorder.fl->opcode)
{ /* The above relies on lvn() always generating an OC_VAR triple first */
term_ref = newtriple(OC_STOTEMP);
term_ref->operand[0] = put_tref(ref);
terminate[arg_cnt] = put_tref(term_ref);
}
}
DEAL_WITH_DANGER(for_stack_level, control_variable, put_tref(init_ref));
term_ref = newtriple(OC_PARAMETER);
term_ref->operand[0] = terminate[arg_cnt];
step_ref = newtriple(OC_PARAMETER);
step_ref->operand[0] = increment[arg_cnt];
step_ref->operand[1] = put_tref(term_ref);
ref = newtriple(OC_FORINIT);
ref->operand[0] = control_variable;
ref->operand[1] = put_tref(step_ref);
not_even_once_addr = newtriple(OC_JMPGTR)->operand;
}
}
if ((0 < arg_cnt) || (TK_COMMA == TREF(window_token)))
{
if (!TAREF1(for_temps, for_stack_level))
TAREF1(for_temps, for_stack_level) = TRUE;
if (NOCLASS == arg_next_addr.oprclass)
arg_next_addr = put_tref(newtriple(OC_CDADDR));
(eval_next_addr[arg_cnt] = newtriple(OC_LDADDR))->destination = arg_next_addr;
}
if (TK_COMMA != TREF(window_token))
break;
newtriple(OC_JMP)->operand[0] = iteration_start_addr_indr;
}
if (not_even_once_addr)
FOR_END_OF_SCOPE(1, *not_even_once_addr); /* 1 means down a level */
forchk1opc = newtriple(OC_FORCHK1); /* FORCHK1 is a do-nothing routine used by the out-of-band mechanism */
*iteration_start_addr = put_tjmp(forchk1opc);
if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token)))
{
stx_error(ERR_SPOREOL);
FOR_POP(BLOWN_FOR);
return FALSE;
}
if (!linetail())
{
TREF(pos_in_chain) = forpos_in_chain;
assert(TREF(source_error_found));
stx_error(TREF(source_error_found));
FOR_POP(BLOWN_FOR);
return FALSE;
}
SAVE_FOR_OVER_ADDR(); /* stash address of next op in the for_stack array */
if (0 < arg_cnt)
newtriple(OC_JMPAT)->operand[0] = put_tref(eval_next_addr[0]);
for (arg_index = 0; arg_index <= arg_cnt; ++arg_index)
{
if (0 < arg_cnt)
tnxtarg(eval_next_addr[arg_index]->operand);
if (TRUE_WITH_INDX == TAREF1(for_temps, for_stack_level))
{ /* since it might have moved, before touching the control variable get a fix on it */
ref = newtriple(OC_RFRSHINDX);
ref->operand[0] = put_ilit(for_stack_level);
ref->operand[1] = put_ilit((increment[arg_index].oprclass || terminate[arg_index].oprclass)
? FALSE : TRUE); /* if increment rather than new value, rfrsh w/ srchindx else putindx */
control_variable = put_tref(ref);
} else
{
assert(control_ref);
control_variable = put_mvar(&control_ref->exorder.fl->operand[0].oprval.vref->mvname);
}
newtriple(OC_PASSTHRU)->operand[0] = control_variable; /* warn off optimizer */
if (terminate[arg_index].oprclass)
{
term_ref = newtriple(OC_PARAMETER);
term_ref->operand[0] = terminate[arg_index];
step_ref = newtriple(OC_PARAMETER);
step_ref->operand[0] = increment[arg_index];
step_ref->operand[1] = put_tref(term_ref);
init_ref = newtriple(OC_PARAMETER);
init_ref->operand[0] = control_variable;
init_ref->operand[1] = put_tref(step_ref);
ref = newtriple(OC_FORLOOP);
/* redirects back to forchk1, which is at the beginning of new iteration */
ref->operand[0] = *iteration_start_addr;
ref->operand[1] = put_tref(init_ref);
} else if (increment[arg_index].oprclass)
{
step_ref = newtriple(OC_ADD);
step_ref->operand[0] = control_variable;
step_ref->operand[1] = increment[arg_index];
ref = newtriple(OC_STO);
ref->operand[0] = control_variable;
ref->operand[1] = put_tref(step_ref);
newtriple(OC_JMP)->operand[0] = *iteration_start_addr;
}
if (arg_index < arg_cnt) /* go back and evaluate the next argument */
newtriple(OC_JMP)->operand[0] = arg_eval_addr[arg_index + 1];
}
FOR_POP(GOOD_FOR);
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 actuallist (oprtype *opr)
{
triple *ref0, *ref1, *ref2, *masktrip, *counttrip;
oprtype ot;
int mask, parmcount;
error_def (ERR_MAXACTARG);
error_def (ERR_NAMEEXPECTED);
error_def (ERR_COMMAORRPARENEXP);
assert (window_token == TK_LPAREN);
advancewindow ();
masktrip = newtriple (OC_PARAMETER);
mask = 0;
counttrip = newtriple (OC_PARAMETER);
masktrip->operand[1] = put_tref (counttrip);
ref0 = counttrip;
if (window_token == TK_RPAREN)
parmcount = 0;
else
for (parmcount = 1; ; parmcount++)
{
if (parmcount > MAX_ACTUALS)
{
stx_error (ERR_MAXACTARG);
return FALSE;
}
if (window_token == TK_PERIOD)
{
advancewindow ();
if (window_token == TK_IDENT)
{
ot = put_mvar (&window_ident);
mask |= (1 << parmcount - 1);
advancewindow ();
}
else if (window_token == TK_ATSIGN)
{
if (!indirection(&ot))
return FALSE;
ref2 = newtriple(OC_INDLVNAMADR);
ref2->operand[0] = ot;
ot = put_tref(ref2);
mask |= (1 << parmcount - 1);
}
else
{
stx_error (ERR_NAMEEXPECTED);
return FALSE;
}
}
else if (window_token == TK_COMMA)
{
ref2 = newtriple(OC_NULLEXP);
ot = put_tref(ref2);
}
else
if (!expr (&ot)) return FALSE;
ref1 = newtriple (OC_PARAMETER);
ref0->operand[1] = put_tref (ref1);
ref1->operand[0] = ot;
if (window_token == TK_COMMA)
{ advancewindow ();
if (window_token == TK_RPAREN)
{ ref0 = ref1;
ref2 = newtriple(OC_NULLEXP);
ot = put_tref(ref2);
ref1 = newtriple (OC_PARAMETER);
ref0->operand[1] = put_tref (ref1);
ref1->operand[0] = ot;
parmcount++;
break;
}
}
else
if (window_token == TK_RPAREN)
break;
else
{
stx_error (ERR_COMMAORRPARENEXP);
return FALSE;
}
ref0 = ref1;
}
advancewindow ();
masktrip->operand[0] = put_ilit (mask);
counttrip->operand[0] = put_ilit (parmcount);
parmcount += 2;
*opr = put_tref (masktrip);
return parmcount;
}
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 f_text(oprtype *a, opctype op)
{
int implicit_offset = 0;
triple *r, *label;
error_def(ERR_TEXTARG);
error_def(ERR_RTNNAME);
r = maketriple(op);
switch (window_token)
{
case TK_CIRCUMFLEX:
implicit_offset = 1;
/* CAUTION - fall-through */
case TK_PLUS:
r->operand[0] = put_str(zero_mstr.addr, 0); /* Null label - top of routine */
break;
case TK_INTLIT:
int_label();
/* CAUTION - fall through */
case TK_IDENT:
if (!(cmd_qlf.qlf & CQ_LOWER_LABELS))
lower_to_upper((uchar_ptr_t)window_ident.addr, (uchar_ptr_t)window_ident.addr, window_ident.len);
r->operand[0] = put_str(window_ident.addr, window_ident.len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&(r->operand[0])))
return FALSE;
r->opcode = OC_INDTEXT;
break;
default:
stx_error(ERR_TEXTARG);
return FALSE;
}
assert(TK_PLUS == window_token || TK_CIRCUMFLEX == window_token || TK_RPAREN == window_token || TK_EOL == window_token);
if (OC_INDTEXT != r->opcode || TK_PLUS == window_token || TK_CIRCUMFLEX == window_token)
{ /* Need another parm chained in to deal with offset and routine name except for the case where an
* indirect specifies the entire argument.
*/
label = newtriple(OC_PARAMETER);
r->operand[1] = put_tref(label);
}
if (TK_PLUS != window_token)
{
if (OC_INDTEXT != r->opcode || TK_CIRCUMFLEX == window_token)
/* Set default offset (0 or 1 as computed above) when offset not specified */
label->operand[0] = put_ilit(implicit_offset);
else
{ /* Fill in indirect text for case where indirect specifies entire operand */
r->opcode = OC_INDFUN;
r->operand[1] = put_ilit((mint)indir_fntext);
}
} else
{ /* Process offset */
advancewindow();
if (!intexpr(&(label->operand[0])))
return FALSE;
}
if (TK_CIRCUMFLEX != window_token)
{ /* No routine specified - default to current routine */
if (OC_INDFUN != r->opcode)
{
if (!run_time)
label->operand[1] = put_str(routine_name.addr, routine_name.len);
else
label->operand[1] = put_tref(newtriple(OC_CURRTN));
}
} else
{ /* Routine has been specified - pull it */
advancewindow();
switch(window_token)
{
case TK_IDENT:
# ifdef GTM_TRIGGER
if (TK_HASH == director_token)
/* Coagulate tokens as necessary (and available) to allow '#' in the routine name */
advwindw_hash_in_mname_allowed();
# endif
label->operand[1] = put_str(window_ident.addr, window_ident.len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&label->operand[1]))
return FALSE;
r->opcode = OC_INDTEXT;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
int m_job(void)
{
int argcnt;
triple *ref,*next;
oprtype label, offset, routine, plist, timeout, arglst, *argptr, argval;
static readonly unsigned char empty_plist[1] = { jp_eol };
bool is_timeout,dummybool;
error_def(ERR_MAXACTARG);
error_def(ERR_RTNNAME);
error_def(ERR_COMMAORRPARENEXP);
error_def(ERR_JOBACTREF);
label = put_str(zero_ident.c,sizeof(mident));
offset = put_ilit((mint)0);
if (!lref(&label, &offset, FALSE, indir_job, TRUE, &dummybool))
return FALSE;
if ((TRIP_REF == label.oprclass) && (OC_COMMARG == label.oprval.tref->opcode))
return TRUE;
if (TK_CIRCUMFLEX != window_token)
{
if (!run_time)
routine = put_str(routine_name,sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
} else
{
advancewindow();
switch(window_token)
{
case TK_IDENT:
routine = put_str(window_ident.c,sizeof(mident));
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&routine))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
argcnt = 0;
if (TK_LPAREN == window_token)
{
advancewindow();
argptr = &arglst;
while(TK_RPAREN != window_token)
{
if (argcnt > MAX_ACTUALS)
{
stx_error(ERR_MAXACTARG);
return FALSE;
}
if (TK_PERIOD == window_token)
{
stx_error(ERR_JOBACTREF);
return FALSE;
}
if (!expr(&argval))
return FALSE;
ref = newtriple(OC_PARAMETER);
ref->operand[0] = argval;
*argptr = put_tref(ref);
argptr = &ref->operand[1];
argcnt++;
if (TK_COMMA == window_token)
advancewindow();
else if (TK_RPAREN != window_token)
{
stx_error(ERR_COMMAORRPARENEXP);
return FALSE;
}
}
advancewindow(); /* jump over close paren */
}
if (TK_COLON == window_token)
{
advancewindow();
if (TK_COLON == window_token)
{
is_timeout = TRUE;
plist = put_str((char *)empty_plist,sizeof(empty_plist));
} else
{
if (!jobparameters(&plist))
return FALSE;
is_timeout = (TK_COLON == window_token);
}
if (is_timeout)
{
advancewindow();
if (!intexpr(&timeout))
return FALSE;
} else
timeout = put_ilit(NO_M_TIMEOUT);
} else
{
is_timeout = FALSE;
plist = put_str((char *)empty_plist,sizeof(empty_plist));
timeout = put_ilit(NO_M_TIMEOUT);
}
ref = newtriple(OC_JOB);
ref->operand[0] = put_ilit(argcnt + 5); /* parameter list + five fixed arguments */
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = label;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = offset;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = routine;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = plist;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = timeout;
if (argcnt)
next->operand[1] = arglst;
if (is_timeout)
newtriple(OC_TIMTRU);
return TRUE;
}
int m_zwatch(void)
{
boolean_t is_count;
opctype op;
oprtype count, name,action;
triple *next, *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (TK_MINUS == TREF(window_token))
{
advancewindow();
switch (TREF(window_token))
{
case TK_ASTERISK:
name = put_str(zero_ident.addr, zero_ident.len);
count = put_ilit(CANCEL_ALL);
advancewindow();
break;
case TK_IDENT:
name = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
count = put_ilit(CANCEL_ONE);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&name))
return FALSE;
count = put_ilit(CANCEL_ONE);
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
action = put_str("",0);
op = OC_WATCHREF;
} else
{
if (TK_EQUAL == TREF(window_token))
{
advancewindow();
op = OC_WATCHMOD;
} else
op = OC_WATCHREF;
switch (TREF(window_token))
{
case TK_IDENT:
name = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&name))
return FALSE;
if ((OC_WATCHREF == op) && (TK_COLON != TREF(window_token)))
{
ref = maketriple(OC_COMMARG);
ref->operand[0] = name;
ref->operand[1] = put_ilit((mint) indir_zwatch);
ins_triple(ref);
return TRUE;
}
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (TK_COLON != TREF(window_token))
{
action = put_str("",0);
count = put_ilit(0);
} else
{
advancewindow();
if (TK_COLON == TREF(window_token))
{
is_count = TRUE;
action = put_str("", 0);
} else
{
if (EXPR_FAIL == expr(&action, MUMPS_STR))
return FALSE;
is_count = (TK_COLON == TREF(window_token));
}
if (is_count)
{
advancewindow();
if (EXPR_FAIL == expr(&count, MUMPS_INT))
return FALSE;
} else
count = put_ilit(0);
}
}
ref = newtriple(op);
ref->operand[0] = name;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = action;
next->operand[1] = count;
return TRUE;
}
int m_zprint(void)
{
oprtype lab1,lab2,off1,off2,rtn;
triple *ref,*next;
bool got_some;
error_def(ERR_LABELEXPECTED);
error_def(ERR_RTNNAME);
got_some = FALSE;
lab1 = put_str(&zero_ident.c[0],sizeof(mident));
off1 = put_ilit(0);
if (window_token != TK_EOL && window_token != TK_SPACE && !lref(&lab1,&off1,TRUE,indir_zprint,TRUE,&got_some))
return FALSE;
if (lab1.oprclass == TRIP_REF && lab1.oprval.tref->opcode == OC_COMMARG)
return TRUE;
if (window_token != TK_CIRCUMFLEX)
{
if (!run_time)
rtn = put_str(routine_name, mid_len ((mident *)routine_name));
else
rtn = put_tref(newtriple(OC_CURRTN));
}
else
{
got_some = TRUE;
advancewindow();
switch(window_token)
{
case TK_IDENT:
rtn = put_str(window_ident.c, mid_len (&window_ident));
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&rtn))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
if (window_token == TK_COLON)
{
if (!got_some)
{ stx_error(ERR_LABELEXPECTED);
return FALSE;
}
lab2 = put_str(&zero_ident.c[0],sizeof(mident));
off2 = put_ilit(0);
advancewindow();
if (!lref(&lab2,&off2,TRUE,indir_zprint,FALSE,&got_some))
return FALSE;
if (!got_some)
{ stx_error(ERR_LABELEXPECTED);
return FALSE;
}
}
else
{
lab2 = lab1;
off2 = off1;
}
ref = newtriple(OC_ZPRINT);
ref->operand[0] = rtn;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = lab1;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = off1;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = lab2;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = off2;
return TRUE;
}
int m_zprint(void)
{
boolean_t got_some;
oprtype lab1, lab2, off1, off2, rtn;
triple *next, *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
got_some = FALSE;
lab1 = put_str(zero_ident.addr, zero_ident.len);
off1 = put_ilit(0);
if ((TK_EOL != TREF(window_token)) && (TK_SPACE != TREF(window_token))
&& !lref(&lab1, &off1, TRUE, indir_zprint, TRUE, &got_some))
return FALSE;
if ((TRIP_REF == lab1.oprclass) && (OC_COMMARG == lab1.oprval.tref->opcode))
return TRUE;
if (TK_CIRCUMFLEX != TREF(window_token))
{ /* Routine not specified, use current routine */
rtn = PUT_CURRENT_RTN;
} else
{
got_some = TRUE;
advancewindow();
switch (TREF(window_token))
{
case TK_IDENT:
# ifdef GTM_TRIGGER
if (TK_HASH == TREF(director_token))
/* Coagulate tokens as necessary (and available) to allow '#' in the rtn name */
advwindw_hash_in_mname_allowed();
# endif
rtn = put_str((TREF(window_ident)).addr, (TREF(window_ident)).len);
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&rtn))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
if (TK_COLON == TREF(window_token))
{
if (!got_some)
{
stx_error(ERR_LABELEXPECTED);
return FALSE;
}
lab2 = put_str(zero_ident.addr, zero_ident.len);
off2 = put_ilit(0);
advancewindow();
if (!lref(&lab2, &off2, TRUE, indir_zprint, FALSE, &got_some))
return FALSE;
if (!got_some)
{
stx_error(ERR_LABELEXPECTED);
return FALSE;
}
} else
{
lab2 = lab1;
off2 = off1;
}
ref = newtriple(OC_ZPRINT);
ref->operand[0] = rtn;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = lab1;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = off1;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = lab2;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = off2;
return TRUE;
}
int f_next( oprtype *a, opctype op)
{
triple *oldchain, tmpchain, *ref, *r, *triptr;
error_def(ERR_VAREXPECTED);
error_def(ERR_LVORDERARG);
error_def(ERR_GVNEXTARG);
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
r = maketriple(op);
switch (window_token)
{
case TK_IDENT:
if (director_token != TK_LPAREN)
{
stx_error(ERR_LVORDERARG);
return FALSE;
}
if (!lvn(&(r->operand[0]),OC_SRCHINDX,r))
return FALSE;
ins_triple(r);
break;
case TK_CIRCUMFLEX:
ref = TREF(shift_side_effects) ? TREF(expr_start) : curtchain->exorder.bl;
if (!gvn())
return FALSE;
/* the following assumes OC_LIT and OC_GVNAME are all one
* gets for an unsubscripted global variable reference */
if ((TREF(shift_side_effects) ? TREF(expr_start) : curtchain)->exorder.bl->exorder.bl->exorder.bl == ref)
{
stx_error(ERR_GVNEXTARG);
return FALSE;
}
r->opcode = OC_GVNEXT;
ins_triple(r);
break;
case TK_ATSIGN:
if (TREF(shift_side_effects))
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!indirection(&(r->operand[0])))
{
setcurtchain(oldchain);
return FALSE;
}
r->operand[1] = put_ilit((mint)indir_fnnext);
ins_triple(r);
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
dqadd(TREF(expr_start), &tmpchain, exorder);
TREF(expr_start) = tmpchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
} else
{
if (!indirection(&(r->operand[0])))
return FALSE;
r->operand[1] = put_ilit((mint)indir_fnnext);
ins_triple(r);
}
r->opcode = OC_INDFUN;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
*a = put_tref(r);
return TRUE;
}
int f_incr(oprtype *a, opctype op)
{
boolean_t ok;
oprtype *increment;
triple incrchain, *oldchain, *r, *savptr, targchain, tmpexpr, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
r = maketriple(op);
/* may need to evaluate the increment (2nd arg) early and use result later: prepare to juggle triple chains */
dqinit(&targchain, exorder); /* a place for the operation and the target */
dqinit(&tmpexpr, exorder); /* a place to juggle the shifted chain in case it's active */
triptr = TREF(expr_start);
savptr = TREF(expr_start_orig); /* but make sure expr_start_orig == expr_start since this is a new chain */
TREF(expr_start_orig) = TREF(expr_start) = &tmpexpr;
oldchain = setcurtchain(&targchain); /* save the result of the first argument 'cause it evaluates 2nd */
switch (TREF(window_token))
{
case TK_IDENT:
/* $INCREMENT() performs an implicit $GET() on a first argument lvn so we use OC_PUTINDX because
* we know only at runtime whether to signal an UNDEF error (depending on whether we have
* VIEW "NOUNDEF" or "UNDEF" state; op_putindx creates the local variable unconditionally, even if
* we have "UNDEF" state, in which case any error in op_fnincr causes an op_kill of that local variable
*/
ok = (lvn(&(r->operand[0]), OC_PUTINDX, 0));
break;
case TK_CIRCUMFLEX:
ok = gvn();
r->opcode = OC_GVINCR;
r->operand[0] = put_ilit(0); /* dummy fill since emit_code does not like empty operand[0] */
break;
case TK_ATSIGN:
ok = indirection(&r->operand[0]);
r->opcode = OC_INDINCR;
break;
default:
ok = FALSE;
break;
}
if (!ok)
{
setcurtchain(oldchain);
return FALSE;
}
TREF(expr_start) = triptr; /* restore original shift chain */
TREF(expr_start_orig) = savptr;
increment = &r->operand[1];
if (TK_COMMA != TREF(window_token))
*increment = put_ilit(1); /* default optional increment to 1 */
else
{
dqinit(&incrchain, exorder); /* a place for the increment */
setcurtchain(&incrchain); /* increment expr must evaluate before the glvn in $INCR(glvn,expr) */
advancewindow();
if (EXPR_FAIL == expr(increment, MUMPS_NUM))
{
setcurtchain(oldchain);
return FALSE;
}
dqadd(&targchain, &incrchain, exorder); /* dir before targ - this is a violation of info hiding */
setcurtchain(&targchain);
}
coerce(increment, OCT_MVAL);
ins_triple(r);
if (&tmpexpr != tmpexpr.exorder.bl)
{ /* one or more OC_GVNAME may have shifted so add to the end of the shift chain */
assert(TREF(shift_side_effects));
dqadd(TREF(expr_start), &tmpexpr, exorder); /* this is a violation of info hiding */
TREF(expr_start) = tmpexpr.exorder.bl;
assert(OC_GVSAVTARG == (TREF(expr_start))->opcode);
triptr = newtriple(OC_GVRECTARG); /* restore the result of the last gvn to preserve $referece (the naked) */
triptr->operand[0] = put_tref(TREF(expr_start));
}
if (!TREF(shift_side_effects) || (GTM_BOOL != TREF(gtm_fullbool)) || (OC_INDINCR != r->opcode))
{ /* put it on the end of the main chain as there's no reason to play more with the ordering */
setcurtchain(oldchain);
triptr = (TREF(curtchain))->exorder.bl;
dqadd(triptr, &targchain, exorder); /* this is a violation of info hiding */
} else /* need full side effects or indirect 1st argument so put everything on the shift chain */
{ /* add the chain after "expr_start" which may be much before "curtchain" */
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
assert(NULL != TREF(expr_start));
dqadd(TREF(expr_start), &targchain, exorder); /* this is a violation of info hiding */
TREF(expr_start) = targchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
}
/* $increment() args need to avoid side effect processing but that's handled in expritem so eval_expr gets $i()'s SE flag */
*a = put_tref(r);
return TRUE;
}
triple *entryref(opctype op1, opctype op2, mint commargcode, boolean_t can_commarg, boolean_t labref, boolean_t textname)
{
oprtype offset, label, routine, rte1;
char rtn_text[SIZEOF(mident_fixed)], lab_text[SIZEOF(mident_fixed)];
mident rtnname, labname;
mstr rtn_str, lbl_str;
triple *ref, *next, *rettrip;
boolean_t same_rout;
rtnname.len = labname.len = 0;
rtnname.addr = &rtn_text[0];
labname.addr = &lab_text[0];
/* These cases don't currently exist but if they start to exist, the code in this
* routine needs to be revisited for proper operation as the textname conditions
* were assumed not to happen if can_commarg was FALSE (which it is in the one
* known use of textname TRUE - in m_zgoto).
*/
assert(!(can_commarg && textname));
switch (window_token)
{
case TK_INTLIT:
int_label();
/* caution: fall through */
case TK_IDENT:
memcpy(labname.addr, window_ident.addr, window_ident.len);
labname.len = window_ident.len;
advancewindow();
if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && !IS_MCODE_RUNNING && can_commarg)
{
rettrip = newtriple(op1);
rettrip->operand[0] = put_mlab(&labname);
return rettrip;
}
label.oprclass = 0;
break;
case TK_ATSIGN:
if(!indirection(&label))
return NULL;
if ((TK_PLUS != window_token) && (TK_CIRCUMFLEX != window_token) && (TK_COLON != window_token)
&& can_commarg)
{
rettrip = ref = maketriple(OC_COMMARG);
ref->operand[0] = label;
ref->operand[1] = put_ilit(commargcode);
ins_triple(ref);
return rettrip;
}
labname.len = 0;
break;
case TK_PLUS:
stx_error(ERR_LABELEXPECTED);
return NULL;
default:
labname.len = 0;
label.oprclass = 0;
break;
}
if (!labref && (TK_PLUS == window_token))
{ /* Have line offset specified */
advancewindow();
if (!intexpr(&offset))
return NULL;
} else
offset.oprclass = 0;
if (TK_CIRCUMFLEX == window_token)
{ /* Have a routine name specified */
advancewindow();
switch(window_token)
{
case TK_IDENT:
MROUT2XTERN(window_ident.addr, rtnname.addr, window_ident.len);
rtn_str.len = rtnname.len = window_ident.len;
rtn_str.addr = rtnname.addr;
advancewindow();
if (!IS_MCODE_RUNNING)
{ /* Triples for indirect code */
same_rout = (MIDENT_EQ(&rtnname, &routine_name) && can_commarg);
if (!textname)
{ /* Resolve routine and label names to addresses for most calls */
if (!label.oprclass && !offset.oprclass)
{ /* Routine only (no label or offset) */
if (same_rout)
{
rettrip = newtriple(op1);
rettrip->operand[0] = put_mlab(&labname);
} else
{
rettrip = maketriple(op2);
if (rtnname.addr[0] == '%')
rtnname.addr[0] = '_';
rettrip->operand[0] = put_cdlt(&rtn_str);
mlabel2xtern(&lbl_str, &rtnname, &labname);
rettrip->operand[1] = put_cdlt(&lbl_str);
ins_triple(rettrip);
}
return rettrip;
} else if (!same_rout)
{
rte1 = put_str(rtn_str.addr, rtn_str.len);
if (rtnname.addr[0] == '%')
rtnname.addr[0] = '_';
routine = put_cdlt(&rtn_str);
ref = newtriple(OC_RHDADDR);
ref->operand[0] = rte1;
ref->operand[1] = routine;
routine = put_tref(ref);
} else
routine = put_tref(newtriple(OC_CURRHD));
} else
{ /* Return the actual names used */
if (!label.oprclass && !offset.oprclass)
{ /* Routine only (no label or offset) */
rettrip = maketriple(op2);
rettrip->operand[0] = put_str(rtn_str.addr, rtn_str.len);
ref = newtriple(OC_PARAMETER);
ref->operand[0] = put_str(labname.addr, labname.len);
ref->operand[1] = put_ilit(0);
rettrip->operand[1] = put_tref(ref);
ins_triple(rettrip);
return rettrip;
} else
routine = put_str(rtn_str.addr, rtn_str.len);
}
} else
{ /* Triples for normal compiled code */
routine = put_str(rtn_str.addr, rtn_str.len);
if (!textname)
{ /* If not returning text name, convert text name to routine header address */
ref = newtriple(OC_RHDADDR1);
ref->operand[0] = routine;
routine = put_tref(ref);
}
}
break;
case TK_ATSIGN:
if (!indirection(&routine))
return NULL;
if (!textname)
{ /* If not returning text name, convert text name to routine header address */
ref = newtriple(OC_RHDADDR1);
ref->operand[0] = routine;
routine = put_tref(ref);
}
break;
default:
stx_error(ERR_RTNNAME);
return NULL;
}
} else
{
if (!label.oprclass && (0 == labname.len))
{
stx_error(ERR_LABELEXPECTED);
return NULL;
}
if (!textname)
routine = put_tref(newtriple(OC_CURRHD));
else
{ /* If we need a name, the mechanism to retrieve it differs between normal and indirect compilation */
if (!IS_MCODE_RUNNING)
/* For normal compile, use routine name set when started compile */
routine = put_str(routine_name.addr, routine_name.len);
else
/* For an indirect compile, obtain the currently running routine header and pull the routine
* name out of that.
*/
routine = put_str(frame_pointer->rvector->routine_name.addr,
frame_pointer->rvector->routine_name.len);
}
}
if (!offset.oprclass)
offset = put_ilit(0);
if (!label.oprclass)
label = put_str(labname.addr, labname.len);
ref = textname ? newtriple(OC_PARAMETER) : newtriple(OC_LABADDR);
ref->operand[0] = label;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = offset;
if (!textname)
next->operand[1] = routine; /* Not needed if giving text names */
rettrip = next = newtriple(op2);
next->operand[0] = routine;
next->operand[1] = put_tref(ref);
return rettrip;
}
int m_zbreak(void)
{
triple *ref, *next;
oprtype label, offset, routine, action, count;
bool cancel, cancel_all, is_count, dummybool;
error_def(ERR_LABELEXPECTED);
error_def(ERR_RTNNAME);
label = put_str((char *)&zero_ident.c[0], sizeof(mident));
cancel_all = FALSE;
action = put_str("B", 1);
if (window_token == TK_MINUS)
{
advancewindow();
cancel = TRUE;
count = put_ilit((mint)CANCEL_ONE);
} else
{
cancel = FALSE;
count = put_ilit((mint)0);
}
if (window_token == TK_ASTERISK)
{
if (cancel)
{
advancewindow();
cancel_all = TRUE;
if (!run_time)
routine = put_str(&routine_name[0], sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
offset = put_ilit((mint) 0);
count = put_ilit((mint) CANCEL_ALL);
} else
{
stx_error(ERR_LABELEXPECTED);
return FALSE;
}
} else
{
offset = put_ilit((mint) 0);
if (!lref(&label,&offset, TRUE, indir_zbreak, !cancel, &dummybool))
return FALSE;
if (label.oprclass == TRIP_REF && label.oprval.tref->opcode == OC_COMMARG)
return TRUE;
if (window_token != TK_CIRCUMFLEX)
{
if (!run_time)
routine = put_str(&routine_name[0], sizeof(mident));
else
routine = put_tref(newtriple(OC_CURRTN));
} else
{
advancewindow();
switch(window_token)
{
case TK_IDENT:
routine = put_str(&window_ident.c[0], sizeof(mident));
advancewindow();
break;
case TK_ATSIGN:
if (!indirection(&routine))
return FALSE;
break;
default:
stx_error(ERR_RTNNAME);
return FALSE;
}
}
if (!cancel && window_token == TK_COLON)
{
advancewindow();
if (window_token == TK_COLON)
{
is_count = TRUE;
action = put_str("B",1);
} else
{
if (!strexpr(&action))
return FALSE;
is_count = window_token == TK_COLON;
}
if (is_count)
{
advancewindow();
if (!intexpr(&count))
return FALSE;
}
}
}
ref = newtriple(OC_SETZBRK);
ref->operand[0] = label;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = offset;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = routine;
next = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(next);
next->operand[0] = action;
ref = newtriple(OC_PARAMETER);
next->operand[1] = put_tref(ref);
ref->operand[0] = count;
return TRUE;
}
