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 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_goto(void)
{
oprtype *cr;
triple *obp, *oldchain, *ref0, *ref1, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!entryref(OC_JMP, OC_EXTJMP, (mint)indir_goto, TRUE, FALSE, FALSE))
{
setcurtchain(oldchain);
return FALSE;
}
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)) && (OC_NOOP != (TREF(expr_start))->opcode))
{
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)) && (OC_NOOP != (TREF(expr_start))->opcode))
{
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;
}
int m_goto(void)
{
triple tmpchain, *oldchain, *obp, *ref0, *ref1, *triptr;
oprtype *cr;
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!entryref(OC_JMP, OC_EXTJMP, (mint) indir_goto, TRUE, FALSE))
{
setcurtchain(oldchain);
return FALSE;
}
setcurtchain(oldchain);
if (window_token == TK_COLON)
{
advancewindow();
cr = (oprtype *) mcalloc(sizeof(oprtype));
if (!bool_expr((bool) FALSE, cr))
return FALSE;
if (expr_start != expr_start_orig)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
}
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/
if (expr_start != expr_start_orig)
{
ref0 = newtriple(OC_JMP);
ref1 = newtriple(OC_GVRECTARG);
ref1->operand[0] = put_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;
}
int f_select(oprtype *a, opctype op)
{
boolean_t first_time, save_saw_side, save_shift;
unsigned int save_depth;
opctype old_op;
oprtype *cnd, endtrip, target, tmparg;
triple *oldchain, *r, *ref, *save_start, *save_start_orig, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
save_shift = TREF(shift_side_effects);
save_saw_side = TREF(saw_side_effect);
save_depth = TREF(expr_depth);
save_start = TREF(expr_start);
save_start_orig = TREF(expr_start_orig);
TREF(shift_side_effects) = FALSE;
TREF(saw_side_effect) = FALSE;
TREF(expr_depth) = 0;
TREF(expr_start) = TREF(expr_start_orig) = NULL;
if (save_shift)
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
}
r = maketriple(op);
first_time = TRUE;
endtrip = put_tjmp(r);
for (;;)
{
cnd = (oprtype *)mcalloc(SIZEOF(oprtype));
if (!bool_expr(FALSE, cnd))
{
if (save_shift)
setcurtchain(oldchain);
return FALSE;
}
if (TK_COLON != TREF(window_token))
{
if (save_shift)
setcurtchain(oldchain);
stx_error(ERR_COLON);
return FALSE;
}
advancewindow();
if (EXPR_FAIL == expr(&tmparg, MUMPS_EXPR))
{
if (save_shift)
setcurtchain(oldchain);
return FALSE;
}
assert(TRIP_REF == tmparg.oprclass);
old_op = tmparg.oprval.tref->opcode;
if (first_time)
{
if ((OC_LIT == old_op) || (oc_tab[old_op].octype & OCT_MVADDR))
{
ref = newtriple(OC_STOTEMP);
ref->operand[0] = tmparg;
tmparg = put_tref(ref);
}
r->operand[0] = target = tmparg;
first_time = FALSE;
} else
{
ref = newtriple(OC_STO);
ref->operand[0] = target;
ref->operand[1] = tmparg;
if (OC_PASSTHRU == tmparg.oprval.tref->opcode)
{
assert(TRIP_REF == tmparg.oprval.tref->operand[0].oprclass);
ref = newtriple(OC_STO);
ref->operand[0] = target;
ref->operand[1] = put_tref(tmparg.oprval.tref->operand[0].oprval.tref);
}
}
ref = newtriple(OC_JMP);
ref->operand[0] = endtrip;
tnxtarg(cnd);
if (TK_COMMA != TREF(window_token))
break;
advancewindow();
}
tmparg = put_ilit(ERR_SELECTFALSE);
ref = newtriple(OC_RTERROR);
ref->operand[0] = tmparg;
ref->operand[1] = put_ilit(FALSE); /* Not a subroutine reference */
ins_triple(r);
assert(!TREF(expr_depth));
TREF(shift_side_effects) = save_shift;
TREF(saw_side_effect) = save_saw_side;
TREF(expr_depth) = save_depth;
TREF(expr_start) = save_start;
TREF(expr_start_orig) = save_start_orig;
if (save_shift)
{
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));
}
*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;
}
int m_do(void)
{
triple tmpchain, *oldchain, *obp, *ref0, *tripsize,
*triptr, *ref1, *calltrip, *routineref, *labelref;
oprtype *cr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if ((TK_SPACE == window_token) || (TK_EOL == window_token))
{
if (!run_time) /* DO SP SP is a noop at run time */
{
calltrip = newtriple(OC_CALLSP);
calltrip->operand[0] = put_mnxl();
calltrip->operand[1] = put_ocnt();
}
return TRUE;
} else if (TK_AMPERSAND == window_token)
{
if (!extern_func(0))
return FALSE;
else
return TRUE;
}
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
setcurtchain(oldchain);
if (!calltrip)
return FALSE;
if (TK_LPAREN == window_token)
{
if (OC_CALL == calltrip->opcode)
{
assert(MLAB_REF == calltrip->operand[0].oprclass);
calltrip->opcode = OC_EXCAL;
ref0 = newtriple(OC_PARAMETER);
calltrip->operand[1] = put_tref(ref0);
ref0->operand[0] = put_tsiz(); /* parm to hold size of jump codegen */
tripsize = ref0->operand[0].oprval.tref;
assert(OC_TRIPSIZE == tripsize->opcode);
} else
{
if (OC_EXTCALL == calltrip->opcode)
{
assert(TRIP_REF == calltrip->operand[1].oprclass);
if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
else
{
assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
assert(TRIP_REF ==
calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
assert(OC_ILIT == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->opcode);
assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->operand[0].oprclass);
if (0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->operand[0].oprval.ilit)
{
stx_error(ERR_ACTOFFSET);
return FALSE;
}
}
} else /* DO _ @dlabel actuallist */
{
assert(OC_COMMARG == calltrip->opcode);
assert(TRIP_REF == calltrip->operand[1].oprclass);
assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
assert(calltrip->exorder.fl == &tmpchain);
routineref = maketriple(OC_CURRHD);
labelref = maketriple(OC_LABADDR);
ref0 = maketriple(OC_PARAMETER);
dqins(calltrip->exorder.bl, exorder, routineref);
dqins(calltrip->exorder.bl, exorder, labelref);
dqins(calltrip->exorder.bl, exorder, ref0);
labelref->operand[0] = calltrip->operand[0];
labelref->operand[1] = put_tref(ref0);
ref0->operand[0] = calltrip->operand[1];
ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
ref0->operand[1] = put_tref(routineref);
calltrip->operand[0] = put_tref(routineref);
calltrip->operand[1] = put_tref(labelref);
}
calltrip->opcode = OC_EXTEXCAL;
ref0 = newtriple(OC_PARAMETER);
ref0->operand[0] = calltrip->operand[1];
calltrip->operand[1] = put_tref(ref0);
}
if (!actuallist(&ref0->operand[1]))
return FALSE;
} else if (OC_CALL == calltrip->opcode)
{
calltrip->operand[1] = put_ocnt();
if (TREF(for_stack_ptr) != TADR(for_stack))
{
if (TAREF1(for_temps, (TREF(for_stack_ptr) - TADR(for_stack))))
calltrip->opcode = OC_FORLCLDO;
}
}
if (TK_COLON == window_token)
{
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 (OC_EXCAL == calltrip->opcode)
{
triptr = newtriple(OC_JMP);
triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
tripsize->operand[0].oprval.tsize->ct = triptr;
}
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);
} else
{
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/
if (OC_EXCAL == calltrip->opcode)
{
triptr = newtriple(OC_JMP);
triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
tripsize->operand[0].oprval.tsize->ct = triptr;
}
}
return TRUE;
}
int exfunc(oprtype *a, boolean_t alias_target)
{
triple *calltrip, *calltrip_opr1_tref, *counttrip, *funret, *labelref, *masktrip;
triple *oldchain, *ref0, *routineref, tmpchain, *triptr;
# if defined(USHBIN_SUPPORTED) || defined(VMS)
triple *tripsize;
# endif
assert(TK_DOLLAR == window_token);
advancewindow();
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
calltrip = entryref(OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE, FALSE);
setcurtchain(oldchain);
if (!calltrip)
return FALSE;
if (OC_EXFUN == calltrip->opcode)
{
assert(MLAB_REF == calltrip->operand[0].oprclass);
# if defined(USHBIN_SUPPORTED) || defined(VMS)
ref0 = newtriple(OC_PARAMETER);
ref0->operand[0] = put_tsiz(); /* Need size of following code gen triple here */
calltrip->operand[1] = put_tref(ref0);
tripsize = ref0->operand[0].oprval.tref;
assert(OC_TRIPSIZE == tripsize->opcode);
# else
ref0 = calltrip;
# endif
} else
{
calltrip_opr1_tref = calltrip->operand[1].oprval.tref;
if (OC_EXTEXFUN == calltrip->opcode)
{
assert(TRIP_REF == calltrip->operand[1].oprclass);
if (OC_CDLIT == calltrip_opr1_tref->opcode)
assert(CDLT_REF == calltrip_opr1_tref->operand[0].oprclass);
else
{
assert(OC_LABADDR == calltrip_opr1_tref->opcode);
assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprclass);
assert(OC_PARAMETER == calltrip_opr1_tref->operand[1].oprval.tref->opcode);
assert(TRIP_REF == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprclass);
assert(OC_ILIT == calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode);
assert(ILIT_REF
== calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass);
if (0 != calltrip_opr1_tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit)
{
stx_error(ERR_ACTOFFSET);
return FALSE;
}
}
} else /* $$ @dlabel [actuallist] */
{
assert(OC_COMMARG == calltrip->opcode);
assert(TRIP_REF == calltrip->operand[1].oprclass);
assert(OC_ILIT == calltrip_opr1_tref->opcode);
assert(ILIT_REF == calltrip_opr1_tref->operand[0].oprclass);
assert(INDIR_DUMMY == calltrip_opr1_tref->operand[0].oprval.ilit);
assert(calltrip->exorder.fl == &tmpchain);
routineref = maketriple(OC_CURRHD);
labelref = maketriple(OC_LABADDR);
ref0 = maketriple(OC_PARAMETER);
dqins(calltrip->exorder.bl, exorder, routineref);
dqins(calltrip->exorder.bl, exorder, labelref);
dqins(calltrip->exorder.bl, exorder, ref0);
labelref->operand[0] = calltrip->operand[0];
labelref->operand[1] = put_tref(ref0);
ref0->operand[0] = calltrip->operand[1];
ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
ref0->operand[1] = put_tref(routineref);
calltrip->operand[0] = put_tref(routineref);
calltrip->operand[1] = put_tref(labelref);
calltrip->opcode = OC_EXTEXFUN;
}
ref0 = newtriple(OC_PARAMETER);
ref0->operand[0] = calltrip->operand[1];
calltrip->operand[1] = put_tref(ref0);
}
if (TK_LPAREN != window_token)
{
masktrip = newtriple(OC_PARAMETER);
counttrip = newtriple(OC_PARAMETER);
masktrip->operand[0] = put_ilit(0);
counttrip->operand[0] = put_ilit(0);
masktrip->operand[1] = put_tref(counttrip);
ref0->operand[1] = put_tref(masktrip);
} else
if (!actuallist(&ref0->operand[1]))
return FALSE;
triptr = oldchain->exorder.bl;
dqadd(triptr, &tmpchain, exorder); /*this is a violation of info hiding*/
if (OC_EXFUN == calltrip->opcode)
{
assert(MLAB_REF == calltrip->operand[0].oprclass);
triptr = newtriple(OC_JMP);
triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
# if defined(USHBIN_SUPPORTED) || defined(VMS)
tripsize->operand[0].oprval.tsize->ct = triptr;
# endif
}
/* If target is an alias, use special container-expecting routine OC_EXFUNRETALS, else regular OC_EXFUNRET */
funret = newtriple((alias_target ? OC_EXFUNRETALS : OC_EXFUNRET));
funret->operand[0] = *a = put_tref(calltrip);
return TRUE;
}
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_do(void)
{
int opcd;
oprtype *cr;
triple *calltrip, *labelref, *obp, *oldchain, *ref0, *ref1, *routineref, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if ((TK_EOL == TREF(window_token)) || (TK_SPACE == TREF(window_token)))
{
if (!run_time) /* DO SP SP is a noop at run time */
{
calltrip = newtriple(OC_CALLSP);
calltrip->operand[0] = put_mnxl();
}
return TRUE;
} else if (TK_AMPERSAND == TREF(window_token))
{
if (!extern_func(0))
return FALSE;
else
return TRUE;
}
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
calltrip = entryref(OC_CALL, OC_EXTCALL, (mint)indir_do, TRUE, FALSE, FALSE);
setcurtchain(oldchain);
if (!calltrip)
return FALSE;
if (TK_LPAREN == TREF(window_token))
{
if (OC_CALL == calltrip->opcode)
{
assert(MLAB_REF == calltrip->operand[0].oprclass);
calltrip->opcode = OC_EXCAL;
ref0 = calltrip;
} else
{
if (OC_EXTCALL == calltrip->opcode)
{
assert(TRIP_REF == calltrip->operand[1].oprclass);
if (OC_CDLIT == calltrip->operand[1].oprval.tref->opcode)
assert(CDLT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
else
{
assert(OC_LABADDR == calltrip->operand[1].oprval.tref->opcode);
assert(TRIP_REF == calltrip->operand[1].oprval.tref->operand[1].oprclass);
assert(OC_PARAMETER == calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode);
assert(TRIP_REF ==
calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass);
DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->opcode);
assert((OC_ILIT == opcd) || (OC_COMINT == opcd));
DEBUG_ONLY(opcd = calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->operand[0].oprclass);
assert((ILIT_REF == opcd) || (TRIP_REF == opcd));
/* The opcd references above added to allow an invalid syntax using indirect values for
* offsets while specifying a parm list to get through the above asserts (invalid syntax
* should not trip asserts) but it leads to the conclusion that the below test may not be
* robust enough since it is looking at a literal integer value when there is none so have
* added further checks mirroring the first checks done in the two most recent asserts to
* make the check more robust. [Example bad code: Do @lbl+@n^artn(arg)]
*/
if ((0 != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->operand[0].oprval.ilit)
|| (OC_ILIT != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->opcode)
|| (ILIT_REF != calltrip->operand[1].oprval.tref->operand[1].oprval.tref->
operand[0].oprval.tref->operand[0].oprclass))
{
stx_error (ERR_ACTOFFSET);
return FALSE;
}
}
} else
{ /* DO _ @dlabel actuallist */
assert(OC_COMMARG == calltrip->opcode);
assert(TRIP_REF == calltrip->operand[1].oprclass);
assert(OC_ILIT == calltrip->operand[1].oprval.tref->opcode);
assert(ILIT_REF == calltrip->operand[1].oprval.tref->operand[0].oprclass);
assert((mint)indir_do == calltrip->operand[1].oprval.tref->operand[0].oprval.ilit);
assert(calltrip->exorder.fl == &tmpchain);
routineref = maketriple(OC_CURRHD);
labelref = maketriple(OC_LABADDR);
ref0 = maketriple(OC_PARAMETER);
dqins(calltrip->exorder.bl, exorder, routineref);
dqins(calltrip->exorder.bl, exorder, labelref);
dqins(calltrip->exorder.bl, exorder, ref0);
labelref->operand[0] = calltrip->operand[0];
labelref->operand[1] = put_tref (ref0);
ref0->operand[0] = calltrip->operand[1];
ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
ref0->operand[1] = put_tref (routineref);
calltrip->operand[0] = put_tref(routineref);
calltrip->operand[1] = put_tref(labelref);
}
calltrip->opcode = OC_EXTEXCAL;
ref0 = newtriple(OC_PARAMETER);
ref0->operand[0] = calltrip->operand[1];
calltrip->operand[1] = put_tref(ref0);
}
if (!actuallist(&ref0->operand[1]))
return FALSE;
} else if (OC_CALL == calltrip->opcode)
{
if (TREF(for_stack_ptr) != (oprtype **)TADR(for_stack))
{
if (TAREF1(for_temps, (TREF(for_stack_ptr) - (oprtype **)TADR(for_stack))))
calltrip->opcode = OC_FORLCLDO;
}
}
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)) && (OC_NOOP != (TREF(expr_start))->opcode))
{
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 (calltrip->opcode == OC_EXCAL)
{
triptr = newtriple(OC_JMP);
triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
}
if ((TREF(expr_start) != TREF(expr_start_orig)) && (OC_NOOP != (TREF(expr_start))->opcode))
{
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);
} else
{
obp = oldchain->exorder.bl;
dqadd(obp, &tmpchain, exorder); /*this is a violation of info hiding*/
if (OC_EXCAL == calltrip->opcode)
{
triptr = newtriple(OC_JMP);
triptr->operand[0] = put_mfun(&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
}
}
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;
}
void op_indget(mval *dst, mval *target, mval *value)
{
icode_str indir_src;
int rval;
ht_ent_mname *tabent;
mstr *obj, object;
oprtype v;
triple *s, *src, *oldchain, tmpchain, *r, *triptr;
var_tabent targ_key;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if ((TREF(ind_source_sp) >= TREF(ind_source_top)) || (TREF(ind_result_sp) >= TREF(ind_result_top)))
rts_error(VARLSTCNT(1) ERR_INDMAXNEST); /* mdbcondition_handler resets ind_result_sp & ind_source_sp */
MV_FORCE_DEFINED(value);
MV_FORCE_STR(target);
indir_src.str = target->str;
indir_src.code = indir_get;
if (NULL == (obj = cache_get(&indir_src)))
{
obj = &object;
if (valid_mname(&target->str))
{
targ_key.var_name = target->str;
COMPUTE_HASH_MNAME(&targ_key);
tabent = lookup_hashtab_mname(&curr_symval->h_symtab, &targ_key);
if (!tabent || !LV_IS_VAL_DEFINED(tabent->value))
*dst = *value;
else
*dst = ((lv_val *)tabent->value)->v;
dst->mvtype &= ~MV_ALIASCONT; /* Make sure alias container property does not pass */
return;
}
comp_init(&target->str);
src = newtriple(OC_IGETSRC);
switch (TREF(window_token))
{
case TK_IDENT:
if (EXPR_FAIL != (rval = lvn(&v, OC_SRCHINDX, 0))) /* NOTE assignment */
{
s = newtriple(OC_FNGET2);
s->operand[0] = v;
s->operand[1] = put_tref(src);
}
break;
case TK_CIRCUMFLEX:
if (EXPR_FAIL != (rval = gvn())) /* NOTE assignment */
{
r = newtriple(OC_FNGVGET1);
s = newtriple(OC_FNGVGET2);
s->operand[0] = put_tref(r);
s->operand[1] = put_tref(src);
}
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 (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */
{
s = newtriple(OC_INDGET);
s->operand[0] = v;
s->operand[1] = put_tref(src);
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
setcurtchain(oldchain);
} else
{
if (EXPR_FAIL != (rval = indirection(&v))) /* NOTE assignment */
{
s = newtriple(OC_INDGET);
s->operand[0] = v;
s->operand[1] = put_tref(src);
}
}
break;
default:
stx_error(ERR_VAREXPECTED);
rval = EXPR_FAIL;
break;
}
v = put_tref(s);
if (EXPR_FAIL == comp_fini(rval, obj, OC_IRETMVAL, &v, target->str.len))
return;
indir_src.str.addr = target->str.addr;
cache_put(&indir_src, obj);
/* Fall into code activation below */
}
*(TREF(ind_result_sp))++ = dst;
*(TREF(ind_source_sp))++ = value;
comp_indr(obj);
return;
}
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 compile_pattern(oprtype *opr, bool is_indirect)
{
ptstr retstr;
mval retmval;
mstr instr;
int status;
triple *oldchain, tmpchain, *ref, *triptr;
if (is_indirect)
{
if (shift_gvrefs)
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!indirection(opr))
{
setcurtchain(oldchain);
return FALSE;
}
ref = newtriple(OC_INDPAT);
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
dqadd(expr_start, &tmpchain, exorder);
expr_start = tmpchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
} else
{
if (!indirection(opr))
return FALSE;
ref = newtriple(OC_INDPAT);
}
ref->operand[0] = *opr;
*opr = put_tref(ref);
return TRUE;
} else
{
instr.addr = (char *)&source_buffer[source_column - 1];
instr.len = strlen(instr.addr);
status = patstr(&instr, &retstr, NULL);
last_source_column = (short int)(instr.addr - (char *)source_buffer);
assert(last_source_column);
if (status)
{ /* status == syntax error when non-zero */
stx_error(status);
return FALSE;
}
retmval.mvtype = MV_STR;
retmval.str.len = retstr.len * sizeof(uint4);
retmval.str.addr = stringpool.free;
if (stringpool.top - stringpool.free < retmval.str.len)
stp_gcol(retmval.str.len);
memcpy(stringpool.free, &retstr.buff[0], retmval.str.len);
stringpool.free += retmval.str.len;
*opr = put_lit(&retmval);
lexical_ptr = (char *)&source_buffer[last_source_column - 1];
advancewindow();
advancewindow();
return TRUE;
}
}
int gvn(void)
{
triple *ref, *t1, *oldchain, tmpchain, *triptr, *s;
oprtype subscripts[MAX_GVSUBSCRIPTS], *sb1, *sb2;
boolean_t shifting, vbar, parse_status;
opctype ox;
char x;
error_def(ERR_MAXNRSUBSCRIPTS);
error_def(ERR_RPARENMISSING);
error_def(ERR_GBLNAME);
error_def(ERR_EXTGBLDEL);
error_def(ERR_GVNAKEDEXTNM);
error_def(ERR_EXPR);
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(window_token == TK_CIRCUMFLEX);
advancewindow();
sb1 = sb2 = subscripts;
ox = 0;
if (shifting = TREF(shift_side_effects))
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
}
if (window_token == TK_LBRACKET || window_token == TK_VBAR)
{ vbar = (window_token == TK_VBAR);
advancewindow();
if (vbar)
parse_status = expr(sb1++);
else
parse_status = expratom(sb1++);
if (!parse_status)
{ stx_error(ERR_EXPR);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
if (window_token == TK_COMMA)
{
advancewindow();
if (vbar)
parse_status = expr(sb1++);
else
parse_status = expratom(sb1++);
if (!parse_status)
{ stx_error(ERR_EXPR);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
} else
*sb1++ = put_str(0,0);
if ((!vbar && window_token != TK_RBRACKET) || (vbar && window_token != TK_VBAR))
{ stx_error(ERR_EXTGBLDEL);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
advancewindow();
ox = OC_GVEXTNAM;
}
if (window_token == TK_IDENT)
{
if (!ox)
ox = OC_GVNAME;
*sb1++ = put_str(window_ident.addr, window_ident.len);
advancewindow();
} else
{ if (ox)
{
stx_error(ERR_GVNAKEDEXTNM);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
if (window_token != TK_LPAREN)
{
stx_error(ERR_GBLNAME);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
ox = OC_GVNAKED;
}
if (window_token == TK_LPAREN)
for (;;)
{
if (sb1 >= ARRAYTOP(subscripts))
{
stx_error(ERR_MAXNRSUBSCRIPTS);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
advancewindow();
if (!expr(sb1))
{
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
assert(sb1->oprclass == TRIP_REF);
s = sb1->oprval.tref;
if (s->opcode == OC_LIT)
*sb1 = make_gvsubsc(&s->operand[0].oprval.mlit->v);
sb1++;
if ((x = window_token) == TK_RPAREN)
{
advancewindow();
break;
}
if (x != TK_COMMA)
{
stx_error(ERR_RPARENMISSING);
if (shifting)
setcurtchain(oldchain);
return FALSE;
}
}
ref = newtriple(ox);
ref->operand[0] = put_ilit((mint)(sb1 - sb2));
for ( ; sb2 < sb1 ; sb2++)
{
t1 = newtriple(OC_PARAMETER);
ref->operand[1] = put_tref(t1);
ref = t1;
ref->operand[0] = *sb2;
}
if (shifting)
{
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));
}
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 f_get(oprtype *a, opctype op)
{
triple *oldchain, *r, tmpchain, *triptr;
oprtype result, *result_ptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
result_ptr = (oprtype *)mcalloc(SIZEOF(oprtype));
result = put_indr(result_ptr);
r = maketriple(op);
switch (TREF(window_token))
{
case TK_IDENT:
if (!lvn(&r->operand[0], OC_SRCHINDX, 0))
return FALSE;
if (TK_COMMA != TREF(window_token))
{
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
r->opcode = OC_FNGET2;
r->operand[1] = result;
break;
case TK_CIRCUMFLEX:
if (!gvn())
return FALSE;
if (TK_COMMA == TREF(window_token))
{ /* 2-argument $GET with global-variable as first argument. In this case generate the following
* sequence of opcodes. OC_FNGVGET1, opcodes-to-evaluate-second-argument-expression, OC_FNGVGET2
*/
r->opcode = OC_FNGVGET1;
ins_triple(r);
triptr = r;
/* Prepare triple for OC_FNGVGET2 */
r = maketriple(op);
r->opcode = OC_FNGVGET2;
r->operand[0] = put_tref(triptr);
r->operand[1] = result;
} else
{
r->opcode = OC_FNGVGET;
r->operand[0] = result;
}
break;
case TK_ATSIGN:
r->opcode = OC_INDGET;
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] = result;
if (TK_COMMA == TREF(window_token))
{
advancewindow();
if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR))
return FALSE;
} else
*result_ptr = put_str(0, 0);
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));
*a = put_tref(r);
return TRUE;
}
if (!indirection(&r->operand[0]))
return FALSE;
r->operand[1] = result;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (TK_COMMA == TREF(window_token))
{
advancewindow();
if (EXPR_FAIL == expr(result_ptr, MUMPS_EXPR))
return FALSE;
} else
*result_ptr = put_str(0, 0);
ins_triple(r);
*a = put_tref(r);
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 f_get(oprtype *a, opctype op)
{
triple tmpchain, *oldchain, *r, *triptr;
triple *jmp_to_get, *ret_get_val;
oprtype result, *result_ptr;
error_def(ERR_VAREXPECTED);
result_ptr = (oprtype *)mcalloc(sizeof(oprtype));
result = put_indr(result_ptr);
jmp_to_get = maketriple(op);
ret_get_val = maketriple(op);
r = maketriple(op);
switch (window_token)
{
case TK_IDENT:
if (!lvn(&r->operand[0], OC_SRCHINDX, 0))
return FALSE;
if (window_token != TK_COMMA)
{
ins_triple(r);
*a = put_tref(r);
return TRUE;
}
r->opcode = OC_FNGET2;
r->operand[1] = result;
break;
case TK_CIRCUMFLEX:
r->opcode = OC_FNGVGET1;
if (!gvn())
return FALSE;
ins_triple(r);
jmp_to_get->opcode = OC_JMPNEQ;
jmp_to_get->operand[0] = put_tjmp(ret_get_val);
ins_triple(jmp_to_get);
ret_get_val->opcode = OC_FNGVGET2;
ret_get_val->operand[0] = put_tref(r);
ret_get_val->operand[1] = result;
if (window_token != TK_COMMA)
*result_ptr = put_str(0,0);
else
{
advancewindow();
if (!expr(result_ptr))
return FALSE;
}
ins_triple(ret_get_val);
*a = put_tref(ret_get_val);
return TRUE;
break;
case TK_ATSIGN:
r->opcode = OC_INDGET;
if (shift_gvrefs)
{
dqinit(&tmpchain, exorder);
oldchain = setcurtchain(&tmpchain);
if (!indirection(&r->operand[0]))
{
setcurtchain(oldchain);
return FALSE;
}
r->operand[1] = result;
if (window_token == TK_COMMA)
{
advancewindow();
if (!expr(result_ptr))
return FALSE;
}
else
*result_ptr = put_str(0, 0);
ins_triple(r);
newtriple(OC_GVSAVTARG);
setcurtchain(oldchain);
dqadd(expr_start, &tmpchain, exorder);
expr_start = tmpchain.exorder.bl;
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
*a = put_tref(r);
return TRUE;
}
if (!indirection(&r->operand[0]))
return FALSE;
r->operand[1] = result;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
if (window_token == TK_COMMA)
{
advancewindow();
if (!expr(result_ptr))
return FALSE;
}
else
*result_ptr = put_str(0, 0);
ins_triple(r);
*a = put_tref(r);
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_order1( oprtype *a, opctype op)
{
triple *oldchain, tmpchain, *r, *triptr;
error_def(ERR_VAREXPECTED);
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
r = maketriple(op);
switch (window_token)
{
case TK_IDENT:
if (director_token != TK_LPAREN)
{
r->opcode = OC_FNLVNAME;
r->operand[0] = put_str(window_ident.addr, window_ident.len);
r->operand[1] = put_ilit(0); /* FALSE - do not return aliased vars with no value */
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_GVORDER;
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_fnorder1);
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_fnorder1);
ins_triple(r);
}
r->opcode = OC_INDFUN;
break;
default:
stx_error(ERR_VAREXPECTED);
return FALSE;
}
*a = put_tref(r);
return TRUE;
}
int exfunc (oprtype *a)
{
triple *ref0, *calltrip, *masktrip, *counttrip, *funret, *tripsize;
triple *triptr;
triple tmpchain, *oldchain, *obp, *routineref, *labelref;
error_def (ERR_ACTOFFSET);
assert (window_token == TK_DOLLAR);
advancewindow();
assert (window_token == TK_DOLLAR);
advancewindow();
dqinit (&tmpchain, exorder);
oldchain = setcurtchain (&tmpchain);
calltrip = entryref (OC_EXFUN, OC_EXTEXFUN, INDIR_DUMMY, TRUE, TRUE);
setcurtchain (oldchain);
if (!calltrip) return FALSE;
if (calltrip->opcode == OC_EXFUN)
{
assert(calltrip->operand[0].oprclass == MLAB_REF);
ref0 = newtriple(OC_PARAMETER);
ref0->operand[0] = put_tsiz(); /* Need size of following code gen triple here */
calltrip->operand[1] = put_tref(ref0);
tripsize = ref0->operand[0].oprval.tref;
assert(OC_TRIPSIZE == tripsize->opcode);
}
else
{
if (calltrip->opcode == OC_EXTEXFUN)
{
assert (calltrip->operand[1].oprclass == TRIP_REF);
if (calltrip->operand[1].oprval.tref->opcode == OC_CDLIT)
assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == CDLT_REF);
else
{
assert (calltrip->operand[1].oprval.tref->opcode == OC_LABADDR);
assert (calltrip->operand[1].oprval.tref->operand[1].oprclass == TRIP_REF);
assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->opcode == OC_PARAMETER);
assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprclass == TRIP_REF);
assert (calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->opcode
== OC_ILIT);
assert
(calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprclass
== ILIT_REF);
if
(calltrip->operand[1].oprval.tref->operand[1].oprval.tref->operand[0].oprval.tref->operand[0].oprval.ilit
!= 0)
{
stx_error (ERR_ACTOFFSET);
return FALSE;
}
}
}
else /* $$ @dlabel [actuallist] */
{
assert (calltrip->opcode == OC_COMMARG);
assert (calltrip->operand[1].oprclass == TRIP_REF);
assert (calltrip->operand[1].oprval.tref->opcode == OC_ILIT);
assert (calltrip->operand[1].oprval.tref->operand[0].oprclass == ILIT_REF);
assert (calltrip->operand[1].oprval.tref->operand[0].oprval.ilit == INDIR_DUMMY);
assert (calltrip->exorder.fl == &tmpchain);
routineref = maketriple (OC_CURRHD);
labelref = maketriple (OC_LABADDR);
ref0 = maketriple (OC_PARAMETER);
dqins (calltrip->exorder.bl, exorder, routineref);
dqins (calltrip->exorder.bl, exorder, labelref);
dqins (calltrip->exorder.bl, exorder, ref0);
labelref->operand[0] = calltrip->operand[0];
labelref->operand[1] = put_tref (ref0);
ref0->operand[0] = calltrip->operand[1];
ref0->operand[0].oprval.tref->operand[0].oprval.ilit = 0;
ref0->operand[1] = put_tref (routineref);
calltrip->operand[0] = put_tref (routineref);
calltrip->operand[1] = put_tref (labelref);
calltrip->opcode = OC_EXTEXFUN;
}
ref0 = newtriple (OC_PARAMETER);
ref0->operand[0] = calltrip->operand[1];
calltrip->operand[1] = put_tref (ref0);
}
if (window_token != TK_LPAREN)
{
masktrip = newtriple (OC_PARAMETER);
counttrip = newtriple (OC_PARAMETER);
masktrip->operand[0] = put_ilit (0);
counttrip->operand[0] = put_ilit (0);
masktrip->operand[1] = put_tref (counttrip);
ref0->operand[1] = put_tref (masktrip);
}
else
if (!actuallist (&ref0->operand[1])) return FALSE;
obp = oldchain->exorder.bl;
dqadd (obp, &tmpchain, exorder); /*this is a violation of info hiding*/
if (calltrip->opcode == OC_EXFUN)
{
assert(calltrip->operand[0].oprclass == MLAB_REF);
triptr = newtriple (OC_JMP);
triptr->operand[0] = put_mfun (&calltrip->operand[0].oprval.lab->mvname);
calltrip->operand[0].oprclass = ILIT_REF; /* dummy placeholder */
tripsize->operand[0].oprval.tsize->ct = triptr;
}
funret = newtriple (OC_EXFUNRET);
funret->operand[0] = *a = put_tref (calltrip);
return TRUE;
}
int compile_pattern(oprtype *opr, boolean_t is_indirect)
{
int status;
ptstr retstr;
mval retmval;
mstr instr;
triple *oldchain, *ref, tmpchain, *triptr;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (is_indirect)
{
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(opr))
{
setcurtchain(oldchain);
return FALSE;
}
ref = newtriple(OC_INDPAT);
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(opr))
return FALSE;
ref = newtriple(OC_INDPAT);
}
ref->operand[0] = *opr;
*opr = put_tref(ref);
return TRUE;
} else
{
instr.addr = (char *)&source_buffer[source_column - 1];
instr.len = STRLEN(instr.addr);
status = patstr(&instr, &retstr, NULL);
TREF(last_source_column) = (short int)(instr.addr - (char *)source_buffer);
assert(TREF(last_source_column));
if (status)
{ /* status == syntax error when non-zero */
stx_error(status);
return FALSE;
}
retmval.mvtype = MV_STR;
retmval.str.len = retstr.len * SIZEOF(uint4);
retmval.str.addr = (char *)stringpool.free;
ENSURE_STP_FREE_SPACE(retmval.str.len);
memcpy(stringpool.free, &retstr.buff[0], retmval.str.len);
stringpool.free += retmval.str.len;
*opr = put_lit(&retmval);
lexical_ptr = instr.addr;
advancewindow();
advancewindow();
return TRUE;
}
}