/* Halt the process similar to op_halt but allow a return code to be specified. If no return code
* is specified, return code 0 is used as a default (making it identical to op_halt).
*/
int m_zhalt(void)
{
triple *triptr;
oprtype ot;
int status;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
/* Let m_halt() handle the case of the missing return code */
if ((TK_SPACE == TREF(window_token)) || (TK_EOL == TREF(window_token)))
return m_halt();
switch (status = expr(&ot, MUMPS_NUM)) /* NOTE assignment */
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
triptr = newtriple(OC_ZHALT);
triptr->operand[0] = ot;
return TRUE;
case EXPR_INDR:
make_commarg(&ot, indir_zhalt);
return TRUE;
default:
assertpro(FALSE);
}
return FALSE; /* This should never get executed, added to make compiler happy */
}
int m_zattach(void)
{
oprtype x;
triple *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if ((TK_EOL == TREF(window_token)) || (TK_SPACE == TREF(window_token)))
{
triptr = newtriple(OC_ZATTACH);
triptr->operand[0] = put_str("",0);
return TRUE;
}
else
{
switch (expr(&x, MUMPS_STR))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
triptr = newtriple(OC_ZATTACH);
triptr->operand[0] = x;
return TRUE;
case EXPR_INDR:
make_commarg(&x,indir_zattach);
return TRUE;
}
}
return FALSE; /* This should never get executed, added to make compiler happy */
}
int m_zsystem(void)
{
oprtype x;
triple *triptr;
if (window_token == TK_EOL || window_token == TK_SPACE)
{
triptr = newtriple(OC_ZSYSTEM);
triptr->operand[0] = put_str("",0);
return TRUE;
}
else
switch (strexpr(&x))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
triptr = newtriple(OC_ZSYSTEM);
triptr->operand[0] = x;
return TRUE;
case EXPR_INDR:
make_commarg(&x,indir_zsystem);
return TRUE;
}
return FALSE; /* This will never get executed, added to make compiler happy */
}
int m_xecute(void)
{
oprtype *cr, x;
triple *obp, *oldchain, *ref0, *ref1, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
dqinit(&tmpchain,exorder);
oldchain = setcurtchain(&tmpchain);
switch (expr(&x, MUMPS_STR))
{
case EXPR_FAIL:
setcurtchain(oldchain);
return FALSE;
case EXPR_INDR:
if (TK_COLON != TREF(window_token))
{
make_commarg(&x,indir_xecute);
break;
}
/* caution: fall through */
case EXPR_GOOD:
ref0 = maketriple(OC_COMMARG);
ref0->operand[0] = x;
ref0->operand[1] = put_ilit(indir_linetail);
ins_triple(ref0);
}
setcurtchain(oldchain);
if (TK_COLON == TREF(window_token))
{
advancewindow();
cr = (oprtype *)mcalloc(SIZEOF(oprtype));
if (!bool_expr(FALSE, cr))
return FALSE;
if (TREF(expr_start) != TREF(expr_start_orig))
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
}
obp = oldchain->exorder.bl;
dqadd(obp,&tmpchain,exorder); /* violates info hiding */
if (TREF(expr_start) != TREF(expr_start_orig))
{
ref0 = newtriple(OC_JMP);
ref1 = newtriple(OC_GVRECTARG);
ref1->operand[0] = put_tref(TREF(expr_start));
*cr = put_tjmp(ref1);
tnxtarg(&ref0->operand[0]);
} else
tnxtarg(cr);
return TRUE;
}
obp = oldchain->exorder.bl;
dqadd(obp,&tmpchain,exorder); /* violates info hiding */
return TRUE;
}
int m_zlink(void)
{
int rval;
triple *ref;
oprtype file, quals;
if (window_token == TK_EOL || window_token == TK_SPACE || window_token == TK_COLON)
{
ref = newtriple(OC_SVGET);
ref->operand[0] = put_ilit(SV_ZSOURCE);
file = put_tref(ref);
if (window_token == TK_COLON)
{
advancewindow();
if (!strexpr(&quals))
return FALSE;
}
else
{
ref = newtriple(OC_SVGET);
ref->operand[0] = put_ilit(SV_ZCOMPILE);
quals = put_tref(ref);
}
}
else
{
if (!(rval = strexpr(&file)))
return FALSE;
if (window_token != TK_COLON)
{
if (rval == EXPR_INDR)
{
make_commarg(&file,indir_zlink);
return TRUE;
}
ref = newtriple(OC_SVGET);
ref->operand[0] = put_ilit(SV_ZCOMPILE);
quals = put_tref(ref);
}
else
{
advancewindow();
if (!strexpr(&quals))
return FALSE;
}
}
ref = newtriple(OC_ZLINK);
ref->operand[0] = file;
ref->operand[1] = quals;
return TRUE;
}
int m_quit(void)
{
int rval;
triple *triptr;
triple *r;
oprtype x;
error_def(ERR_QUITARGUSE);
error_def(ERR_QUITARGLST);
if (for_stack_ptr == for_stack)
{
if (window_token == TK_EOL || window_token == TK_SPACE)
newtriple((run_time) ? OC_HARDRET : OC_RET);
else
{
if (!(rval = expr(&x)))
return FALSE;
if (EXPR_INDR == rval)
{ /* Indirect argument */
make_commarg(&x, indir_quit);
return TRUE;
}
r = newtriple(OC_RETARG);
r->operand[0] = x;
if (window_token == TK_COMMA)
{
stx_error (ERR_QUITARGLST);
return FALSE;
}
}
} else
{
if (window_token == TK_EOL || window_token == TK_SPACE)
{
triptr = newtriple(OC_JMP);
triptr->operand[0] = for_end_of_scope(1);
} else
{
stx_error(ERR_QUITARGUSE);
return FALSE;
}
}
return TRUE;
}
int m_write(void)
{
error_def(ERR_STRINGOFLOW);
oprtype x,*oprptr;
mval lit;
mstr *msp;
int lnx;
char *cp;
triple *ref, *t1;
triple *litlst[128], **llptr, **ptx, **ltop;
llptr = litlst;
ltop = 0;
*llptr = 0;
for (;;)
{
devctlexp = FALSE;
switch(window_token)
{
case TK_ASTERISK:
advancewindow();
if (!intexpr(&x))
return FALSE;
assert(x.oprclass == TRIP_REF);
ref = newtriple(OC_WTONE);
ref->operand[0] = x;
STO_LLPTR((x.oprval.tref->opcode == OC_ILIT) ? ref : 0);
break;
case TK_QUESTION:
case TK_EXCLAIMATION:
case TK_HASH:
case TK_SLASH:
if (!rwformat())
return FALSE;
STO_LLPTR(0);
break;
default:
switch (strexpr(&x))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
assert(x.oprclass == TRIP_REF);
if (devctlexp)
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR(0);
} else if (x.oprval.tref->opcode == OC_CAT)
{
wrtcatopt(x.oprval.tref,&llptr,LITLST_TOP);
} else
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR((x.oprval.tref->opcode == OC_LIT) ? ref : 0);
}
break;
case EXPR_INDR:
make_commarg(&x,indir_write);
STO_LLPTR(0);
break;
default:
assert(FALSE);
}
break;
}
if (window_token != TK_COMMA)
break;
advancewindow();
if (llptr >= LITLST_TOP)
{
*++llptr = 0;
ltop = llptr;
llptr = 0;
}
}
STO_LLPTR(0);
if (ltop)
llptr = ltop;
for (ptx = litlst ; ptx < llptr ; ptx++)
{
if (*ptx && *(ptx + 1))
{
lit.mvtype = MV_STR;
lit.str.addr = cp = (char * ) stringpool.free;
for (t1 = ref = *ptx++ ; ref ; ref = *ptx++)
{
if (ref->opcode == OC_WRITE)
{
msp = &(ref->operand[0].oprval.tref->operand[0].oprval.mlit->v.str);
lnx = msp->len;
if ( cp + lnx > (char *) stringpool.top)
{ stx_error(ERR_STRINGOFLOW);
return FALSE;
}
memcpy(cp, msp->addr, lnx);
cp += lnx;
}
else
{
assert(ref->opcode == OC_WTONE);
if (cp + 1 > (char *) stringpool.top)
{ stx_error(ERR_STRINGOFLOW);
return FALSE;
}
*cp++ = ref->operand[0].oprval.tref->operand[0].oprval.ilit;
}
ref->operand[0].oprval.tref->opcode = OC_NOOP;
ref->opcode = OC_NOOP;
ref->operand[0].oprval.tref->operand[0].oprclass = OC_NOOP;
ref->operand[0].oprclass = 0;
}
ptx--;
stringpool.free = (unsigned char *) cp;
lit.str.len = INTCAST(cp - lit.str.addr);
s2n(&lit);
t1->opcode = OC_WRITE;
t1->operand[0] = put_lit(&lit);
}
}
return TRUE;
}
int m_write(void)
{
char *cp;
int lnx;
mval lit;
mstr *msp;
oprtype *oprptr, x;
triple *litlst[128], **llptr, **ltop, **ptx, *ref, *t1;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
llptr = litlst;
ltop = 0;
*llptr = 0;
for (;;)
{
devctlexp = FALSE;
switch (TREF(window_token))
{
case TK_ASTERISK:
advancewindow();
if (EXPR_FAIL == expr(&x, MUMPS_INT))
return FALSE;
assert(TRIP_REF == x.oprclass);
ref = newtriple(OC_WTONE);
ref->operand[0] = x;
STO_LLPTR((OC_ILIT == x.oprval.tref->opcode) ? ref : 0);
break;
case TK_QUESTION:
case TK_EXCLAIMATION:
case TK_HASH:
case TK_SLASH:
if (!rwformat())
return FALSE;
STO_LLPTR(0);
break;
default:
switch (expr(&x, MUMPS_STR))
{
case EXPR_FAIL:
return FALSE;
case EXPR_GOOD:
assert(TRIP_REF == x.oprclass);
if (devctlexp)
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR(0);
} else if (x.oprval.tref->opcode == OC_CAT)
wrtcatopt(x.oprval.tref, &llptr, LITLST_TOP);
else
{
ref = newtriple(OC_WRITE);
ref->operand[0] = x;
STO_LLPTR((OC_LIT == x.oprval.tref->opcode) ? ref : 0);
}
break;
case EXPR_INDR:
make_commarg(&x, indir_write);
STO_LLPTR(0);
break;
default:
assert(FALSE);
}
break;
}
if (TK_COMMA != TREF(window_token))
break;
advancewindow();
if (LITLST_TOP <= llptr)
{
*++llptr = 0;
ltop = llptr;
llptr = 0;
}
}
STO_LLPTR(0);
if (ltop)
llptr = ltop;
for (ptx = litlst ; ptx < llptr ; ptx++)
{
if (*ptx && *(ptx + 1))
{
lit.mvtype = MV_STR;
lit.str.addr = cp = (char *)stringpool.free;
CLEAR_MVAL_BITS(&lit);
for (t1 = ref = *ptx++ ; ref ; ref = *ptx++)
{
if (OC_WRITE == ref->opcode)
{
msp = &(ref->operand[0].oprval.tref->operand[0].oprval.mlit->v.str);
lnx = msp->len;
ENSURE_STP_FREE_SPACE(lnx);
memcpy(cp, msp->addr, lnx);
cp += lnx;
} else
{
assert(OC_WTONE == ref->opcode);
ENSURE_STP_FREE_SPACE(1);
*cp++ = ref->operand[0].oprval.tref->operand[0].oprval.ilit;
}
ref->operand[0].oprval.tref->opcode = OC_NOOP;
ref->opcode = OC_NOOP;
ref->operand[0].oprval.tref->operand[0].oprclass = NO_REF;
ref->operand[0].oprclass = NO_REF;
}
ptx--;
stringpool.free = (unsigned char *) cp;
lit.str.len = INTCAST(cp - lit.str.addr);
t1->opcode = OC_WRITE;
t1->operand[0] = put_lit(&lit);
}
}
return TRUE;
}
int m_zgoto(void)
{
triple tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr;
oprtype *cr, quits;
int4 rval;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if ((TK_EOL == window_token) || (TK_SPACE == window_token))
{ /* Default zgoto level is 1 */
quits = put_ilit(1);
rval = EXPR_GOOD;
} else if (!(rval = intexpr(&quits))) /* note assignment */
{
setcurtchain(oldchain);
return FALSE;
}
if ((EXPR_INDR != rval) && ((TK_EOL == window_token) || (TK_SPACE == window_token)))
{ /* Only level parm supplied (no entry ref) - job for op_zg1 */
setcurtchain(oldchain);
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */
ref0 = newtriple(OC_ZG1);
ref0->operand[0] = quits;
return TRUE;
}
if (TK_COLON != window_token)
{ /* First arg parsed, not ending in ":". Better have been indirect */
setcurtchain(oldchain);
if (EXPR_INDR != rval)
{
stx_error(ERR_COLON);
return FALSE;
}
make_commarg(&quits, indir_zgoto);
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */
return TRUE;
}
advancewindow();
if (TK_COLON != window_token)
{
if (!entryref(OC_NOOP, OC_PARAMETER, (mint)indir_goto, FALSE, FALSE, TRUE))
{
setcurtchain(oldchain);
return FALSE;
}
ref0 = maketriple(OC_ZGOTO);
ref0->operand[0] = quits;
ref0->operand[1] = put_tref(tmpchain.exorder.bl);
ins_triple(ref0);
setcurtchain(oldchain);
} else
{
ref0 = maketriple(OC_ZG1);
ref0->operand[0] = quits;
ins_triple(ref0);
setcurtchain(oldchain);
}
if (TK_COLON == window_token)
{ /* post conditional expression */
advancewindow();
cr = (oprtype *)mcalloc(SIZEOF(oprtype));
if (!bool_expr((bool)FALSE, cr))
return FALSE;
if (TREF(expr_start) != TREF(expr_start_orig))
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(TREF(expr_start));
}
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */
if (TREF(expr_start) != TREF(expr_start_orig))
{
ref0 = newtriple(OC_JMP);
ref1 = newtriple(OC_GVRECTARG);
ref1->operand[0] = put_tref(TREF(expr_start));
*cr = put_tjmp(ref1);
tnxtarg(&ref0->operand[0]);
} else
tnxtarg(cr);
return TRUE;
}
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /* this is a violation of info hiding */
return TRUE;
}
