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_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;
}
void bx_boollit_tail(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr)
/* search the Boolean in t (recursively) for literal leaves; the logic is similar to bx_tail
* the rest of the arguments parallel those in bx_boolop and used primarily handling basic Boolean operations (ON, NOR, AND, NAND)
* to get the jump target and sense right for the left-hand operand of the operation
* jmp_type_one gives the sense of the jump associated with the first operand
* jmp_to_next gives whether we need a second jump to complete the operation
* sense gives the sense of the requested operation
* *addr points the operand for the jump and is eventually used by logic back in the invocation stack to fill in a target location
*/
{
boolean_t sin[ARRAYSIZE(t->operand)], tv[ARRAYSIZE(t->operand)];
int com, comval, dummy, j, neg, num, tvr;
mval *mv, *v[ARRAYSIZE(t->operand)];
opctype c;
oprtype *i, *p;
triple *cob[ARRAYSIZE(t->operand)], *ref0, *tl[ARRAYSIZE(t->operand)];
assert(OCT_BOOL & oc_tab[t->opcode].octype);
assert(TRIP_REF == t->operand[0].oprclass);
assert((OC_COBOOL != t->opcode) && (OC_COM != t->opcode) || (TRIP_REF == t->operand[1].oprclass));
for (i = t->operand, j = 0; i < ARRAYTOP(t->operand); i++, j++)
{ /* checkout an operand to see if we can simplify it */
p = i;
com = 0;
for (tl[j] = i->oprval.tref; OCT_UNARY & oc_tab[(c = tl[j]->opcode)].octype; tl[j] = p->oprval.tref)
{ /* find the real object of affection; WARNING assignment above */
assert((TRIP_REF == tl[j]->operand[0].oprclass) && (NO_REF == tl[j]->operand[1].oprclass));
com ^= (OC_COM == c); /* if we make a recursive call below, COM matters, but NEG and FORCENUM don't */
p = &tl[j]->operand[0];
}
if (OCT_ARITH & oc_tab[c].octype)
ex_tail(p); /* chained arithmetic */
else if (OCT_BOOL & oc_tab[c].octype)
{ /* recursively check an operand */
sin[j] = sense;
p = addr;
if (!j && !(OCT_REL & oc_tab[t->opcode].octype))
{ /* left hand operand of parent */
sin[j] = jmp_type_one;
if (jmp_to_next)
{ /* left operands need extra attention to decide between jump next or to the end */
p = (oprtype *)mcalloc(SIZEOF(oprtype));
*p = put_tjmp(t);
}
}
bx_boollit(tl[j], sin[j] ^ com, p);
}
if ((OC_JMPTRUE != tl[j]->opcode) && (OC_JMPFALSE != tl[j]->opcode) && (OC_LIT != tl[j]->opcode))
return; /* this operation doesn't qualify */
com = comval = neg = num = 0;
cob[j] = NULL;
for (ref0 = i->oprval.tref; OCT_UNARY & oc_tab[(c = ref0->opcode)].octype; ref0 = ref0->operand[0].oprval.tref)
{ /* we may be able to clean up this operand; WARNING assignment above */
assert((TRIP_REF == ref0->operand[0].oprclass) && (NO_REF == ref0->operand[1].oprclass));
num += (OC_FORCENUM == c);
com += (OC_COM == c);
if (!com) /* "outside" com renders neg mute */
neg ^= (OC_NEG == c);
if (!comval && (NULL == cob[j]))
{
if (comval = (OC_COMVAL == c)) /* WARNING assignment */
{
if (ref0 != t->operand[j].oprval.tref)
dqdel(t->operand[j].oprval.tref, exorder);
t->operand[j].oprval.tref = tl[j]; /* need mval: no COBOOL needed */
}
else if (OC_COBOOL == c)
{ /* the operand needs a COBOOL in case its operator remains unresolved */
cob[j] = t->operand[j].oprval.tref;
if (ref0 == cob[j])
continue; /* already where it belongs */
cob[j]->opcode = OC_COBOOL;
cob[j]->operand[0].oprval.tref = tl[j];
} else if (ref0 == t->operand[j].oprval.tref)
continue;
}
dqdel(ref0, exorder);
}
assert(ref0 == tl[j]);
if (!comval && (NULL == cob[j]) && (tl[j] != t->operand[j].oprval.tref))
{ /* left room for a COBOOL, but there's no need */
dqdel(t->operand[j].oprval.tref, exorder);
t->operand[j].oprval.tref = tl[j];
}
if ((OC_JMPTRUE == ref0->opcode) || (OC_JMPFALSE == ref0->opcode))
{ /* switch to a literal representation of TRUE / FALSE */
assert(INDR_REF == ref0->operand[0].oprclass);
ref0->operand[1] = ref0->operand[0]; /* track info as we switch opcode */
PUT_LITERAL_TRUTH((sin[j] ? OC_JMPFALSE : OC_JMPTRUE) == ref0->opcode, ref0);
ref0->opcode = OC_LIT;
com = 0; /* already accounted for by sin */
}
assert((OC_LIT == ref0->opcode) && (MLIT_REF == ref0->operand[0].oprclass));
v[j] = &ref0->operand[0].oprval.mlit->v;
if (com)
{ /* any complement reduces the literal value to [unsigned] 1 or 0 */
unuse_literal(v[j]);
tv[j] = (0 == v[j]->m[1]);
assert(ref0 == tl[j]);
PUT_LITERAL_TRUTH(tv[j], ref0);
v[j] = &ref0->operand[0].oprval.mlit->v;
num = 0; /* any complement trumps num */
}
if (neg || num)
{ /* get literal into uniform state */
unuse_literal(v[j]);
mv = (mval *)mcalloc(SIZEOF(mval));
*mv = *v[j];
if (neg)
{
if (MV_INT & mv->mvtype)
{
if (0 != mv->m[1])
mv->m[1] = -mv->m[1];
else
mv->sgn = 0;
} else if (MV_NM & mv->mvtype)
mv->sgn = !mv->sgn;
} else
s2n(mv);
n2s(mv);
v[j] = mv;
assert(ref0 == tl[j]);
put_lit_s(v[j], ref0);
}
}
assert(tl[0] != tl[1]); /* start processing a live one */
for (tvr = j, j = 0; j < tvr; j++)
{ /* both arguments are literals, so do the operation at compile time */
if (NULL != cob[j])
dqdel(cob[j], exorder);
v[j] = &tl[j]->operand[0].oprval.mlit->v;
tv[j] = (0 != v[j]->m[1]);
unuse_literal(v[j]);
tl[j]->opcode = OC_NOOP;
tl[j]->operand[0].oprclass = NO_REF;
}
t->operand[1].oprclass = NO_REF;
switch (c = t->opcode) /* WARNING assignment */
{ /* optimize the Boolean operations here */
case OC_NAND:
case OC_AND:
tvr = (tv[0] && tv[1]);
break;
case OC_NOR:
case OC_OR:
tvr = (tv[0] || tv[1]);
break;
case OC_NCONTAIN:
case OC_CONTAIN:
tvr = 1;
(void)matchc(v[1]->str.len, (unsigned char *)v[1]->str.addr, v[0]->str.len,
(unsigned char *)v[0]->str.addr, &dummy, &tvr);
tvr ^= 1;
break;
case OC_NEQU:
case OC_EQU:
tvr = is_equ(v[0], v[1]);
break;
case OC_NFOLLOW:
case OC_FOLLOW:
tvr = 0 < memvcmp(v[0]->str.addr, v[0]->str.len, v[1]->str.addr, v[1]->str.len);
break;
case OC_NGT:
case OC_GT:
tvr = 0 < numcmp(v[0], v[1]);
break;
case OC_NLT:
case OC_LT:
tvr = 0 > numcmp(v[0], v[1]);
break;
case OC_NPATTERN:
case OC_PATTERN:
tvr = !(*(uint4 *)v[1]->str.addr) ? do_pattern(v[0], v[1]) : do_patfixed(v[0], v[1]);
break;
case OC_NSORTS_AFTER:
case OC_SORTS_AFTER:
tvr = 0 < sorts_after(v[0], v[1]);
break;
default:
assertpro(FALSE);
}
tvr ^= !sense;
t->operand[0] = put_indr(addr);
t->opcode = tvr ? OC_JMPFALSE : OC_JMPTRUE;
return;
}
int m_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 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 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_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 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 bx_boolop(triple *t, boolean_t jmp_type_one, boolean_t jmp_to_next, boolean_t sense, oprtype *addr)
{
boolean_t expr_fini;
oprtype *adj_addr, *i, *p;
tbp *tripbp;
triple *ref0, *ref1, *ref2, *t0, *t1;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
assert(((1 & sense) == sense) && ((1 & jmp_to_next) == jmp_to_next) && ((1 & jmp_type_one) == jmp_type_one));
assert((TRIP_REF == t->operand[0].oprclass) && (TRIP_REF == t->operand[1].oprclass));
if (jmp_to_next)
{
p = (oprtype *)mcalloc(SIZEOF(oprtype));
*p = put_tjmp(t);
} else
p = addr;
if (GTM_BOOL == TREF(gtm_fullbool) || !TREF(saw_side_effect))
{ /* nice simple short circuit */
assert(NULL == TREF(boolchain_ptr));
bx_tail(t->operand[0].oprval.tref, jmp_type_one, p);
bx_tail(t->operand[1].oprval.tref, sense, addr);
t->opcode = OC_NOOP;
t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
return;
}
/* got a side effect and don't want them short circuited */
/* This code violates info hiding big-time and relies on the original technique of setting up a jump ladder
* then it changes the jumps into stotemps and creates a new ladder using the saved evaluations
* for the relocated jumps to use for controlling conditional transfers, When the stotemps reference mvals,
* they are optimized away when possible. The most interesting part is getting the addresses for the new jump
* operands (targets) - see comment below. In theory we could turn this technique on and off around each side effect,
* but that's even more complicated, requiring additional instructions, and we don't predict the typical boolean
* expression has enough subexpressions to justify the extra trouble, although the potential pay-back would be to
* avoid unnecessary global references - again, not expecting that many in a typical boolean expresion.
*/
assert(TREF(shift_side_effects));
if (expr_fini = (NULL == TREF(boolchain_ptr))) /* NOTE assignment */
{ /* initialize work on boolean section of the AST */
TREF(boolchain_ptr) = &(TREF(boolchain));
dqinit(TREF(boolchain_ptr), exorder);
t0 = t->exorder.fl;
if (NULL == TREF(bool_targ_ptr))
{ /* first time - set up anchor */
TREF(bool_targ_ptr) = &(TREF(bool_targ_anchor)); /* mcalloc won't persist over multiple complies */
dqinit(TREF(bool_targ_ptr), que);
} else /* queue should be empty */
assert((TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.fl)
&& (TREF(bool_targ_ptr) == (TREF(bool_targ_ptr))->que.bl));
/* ex_tail wraps bools that produce a value with OC_BOOLINIT (clr) and OC_BOOLFINI (set) */
assert((OC_BOOLFINI != t0->opcode)
|| ((OC_COMVAL == t0->exorder.fl->opcode) && (TRIP_REF == t0->operand[0].oprclass)));
}
for (i = t->operand; i < ARRAYTOP(t->operand); i++)
{
assert(NULL != TREF(boolchain_ptr));
t1 = i->oprval.tref;
if (&(t->operand[0]) == i)
bx_tail(t1, jmp_type_one, p); /* do normal transform */
else
{ /* operand[1] */
bx_tail(t1, sense, addr); /* do normal transform */
if (!expr_fini)
break; /* only need to relocate last operand[1] */
}
if (OC_NOOP == t1->opcode)
{ /* the technique of sprinkling noops means fishing around for the actual instruction */
do
{
t1 = t1->exorder.bl;
assert(TREF(curtchain) != t1->exorder.bl);
} while (OC_NOOP == t1->opcode);
if ((oc_tab[t1->opcode].octype & OCT_JUMP) && (OC_JMPTSET != t1->opcode) && (OC_JMPTCLR != t1->opcode))
t1 = t1->exorder.bl;
if (OC_NOOP == t1->opcode)
{
for (t1 = i->oprval.tref; OC_NOOP == t1->opcode; t1 = t1->exorder.fl)
assert(TREF(curtchain) != t1->exorder.fl);
}
}
assert(OC_NOOP != t1->opcode);
assert((oc_tab[t1->exorder.fl->opcode].octype & OCT_JUMP)
||(OC_JMPTSET != t1->exorder.fl->opcode) || (OC_JMPTCLR != t1->exorder.fl->opcode));
ref0 = maketriple(t1->opcode); /* copy operation for place in new ladder */
ref1 = (TREF(boolchain_ptr))->exorder.bl; /* common setup for above op insert */
switch (t1->opcode)
{ /* time to subvert original jump ladder entry */
case OC_COBOOL:
/* insert COBOOL and copy of following JMP in boolchain; overlay them with STOTEMP and NOOP */
assert(TRIP_REF == t1->operand[0].oprclass);
dqins(ref1, exorder, ref0);
if (oc_tab[t1->operand[0].oprval.tref->opcode].octype & OCT_MVAL)
{ /* do we need a STOTEMP? */
switch (t1->operand[0].oprval.tref->opcode)
{
case OC_INDGLVN: /* indirect actions not happy without STOTEMP */
case OC_INDNAME:
case OC_VAR: /* variable could change so must save it */
t1->opcode = OC_STOTEMP;
ref0->operand[0] = put_tref(t1);/* new COBOOL points to this OC_STOTEMP */
break;
default: /* else no temporary if it's mval */
ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
t1->opcode = OC_NOOP;
t1->operand[0].oprclass = NOCLASS;
}
} else
{ /* make it an mval instead of COBOOL now */
t1->opcode = OC_COMVAL;
ref0->operand[0] = put_tref(t1); /* new COBOOL points to this OC_COMVAL */
}
t1 = t1->exorder.fl;
ref0 = maketriple(t1->opcode); /* create new jmp on result of coerce */
ref0->operand[0] = t1->operand[0];
t1->opcode = OC_NOOP; /* wipe out original jmp */
t1->operand[0].oprclass = NOCLASS;
break;
case OC_CONTAIN:
case OC_EQU:
case OC_FOLLOW:
case OC_NUMCMP:
case OC_PATTERN:
case OC_SORTS_AFTER:
/* insert copies of orig OC and following JMP in boolchain & overly originals with STOTEMPs */
assert(TRIP_REF == t1->operand[0].oprclass);
assert(TRIP_REF == t1->operand[1].oprclass);
dqins(ref1, exorder, ref0);
if (OC_VAR == t1->operand[0].oprval.tref->opcode)
{ /* VAR could change so must save it */
t1->opcode = OC_STOTEMP; /* overlay the original op with a STOTEMP */
ref0->operand[0] = put_tref(t1); /* new op points to thi STOTEMP */
} else
{ /* no need for a temporary unless it's a VAR */
ref0->operand[0] = put_tref(t1->operand[0].oprval.tref);
t1->opcode = OC_NOOP;
}
ref1 = t1;
t1 = t1->exorder.fl;
ref2 = maketriple(t1->opcode); /* copy jmp */
ref2->operand[0] = t1->operand[0];
if (OC_VAR == ref1->operand[1].oprval.tref->opcode)
{ /* VAR could change so must save it */
ref0->operand[1] = put_tref(t1); /* new op points to STOTEMP overlaying the jmp */
t1->operand[0] = ref1->operand[1];
t1->opcode = OC_STOTEMP; /* overlay jmp with 2nd STOTEMP */
} else
{ /* no need for a temporary unless it's a VAR */
ref0->operand[1] = put_tref(ref1->operand[1].oprval.tref);
t1->opcode = OC_NOOP;
t1->operand[0].oprclass = NOCLASS;
}
if (OC_NOOP == ref1->opcode) /* does op[0] need cleanup? */
ref1->operand[0].oprclass = ref1->operand[1].oprclass = NOCLASS;
ref0 = ref2;
break;
case OC_JMPTSET:
case OC_JMPTCLR:
/* move copy of jmp to boolchain and NOOP it */
ref0->operand[0] = t1->operand[0]; /* new jmpt gets old target */
ref2 = maketriple(OC_NOOP); /* insert a NOOP in new chain inplace of COBOOL */
dqins(ref1, exorder, ref2);
t1->opcode = OC_NOOP; /* wipe out original jmp */
t1->operand[0].oprclass = NOCLASS;
break;
default:
assertpro(FALSE);
}
assert((OC_STOTEMP == t1->opcode) || (OC_NOOP == t1->opcode) || (OC_COMVAL == t1->opcode));
assert(oc_tab[ref0->opcode].octype & OCT_JUMP);
ref1 = (TREF(boolchain_ptr))->exorder.bl;
dqins(ref1, exorder, ref0); /* common insert for new jmp */
}
assert(oc_tab[t->opcode].octype & OCT_BOOL);
t->opcode = OC_NOOP; /* wipe out the original boolean op */
t->operand[0].oprclass = t->operand[1].oprclass = NOCLASS;
tripbp = &t->jmplist; /* borrow jmplist to track jmp targets */
assert(NULL == tripbp->bpt);
assert((tripbp == tripbp->que.fl) && (tripbp == tripbp->que.bl));
tripbp->bpt = jmp_to_next ? (TREF(boolchain_ptr))->exorder.bl : ref0; /* point op triple at op[1] position or op[0] */
dqins(TREF(bool_targ_ptr), que, tripbp); /* queue jmplist for clean-up */
if (!expr_fini)
return;
/* time to deal with new jump ladder */
assert(NULL != TREF(boolchain_ptr));
assert(NULL != TREF(bool_targ_ptr));
assert(TREF(bool_targ_ptr) != (TREF(bool_targ_ptr))->que.fl);
assert(t0->exorder.bl == t);
assert(t0 == t->exorder.fl);
dqadd(t, TREF(boolchain_ptr), exorder); /* insert the new jump ladder */
ref0 = (TREF(boolchain_ptr))->exorder.bl->exorder.fl;
t0 = t->exorder.fl;
if (ref0 == TREF(curtchain))
{ /* add a safe target */
newtriple(OC_NOOP);
ref0 = (TREF(curtchain))->exorder.bl;
}
assert((OC_COBOOL == t0->opcode) ||(OC_JMPTSET != t0->opcode) || (OC_JMPTCLR != t0->opcode)) ;
t0 = t0->exorder.fl;
assert(oc_tab[t0->opcode].octype & OCT_JUMP);
for (; (t0 != ref0) && oc_tab[t0->opcode].octype & OCT_JUMP; t0 = t0->exorder.fl)
{ /* process replacement jmps */
adj_addr = &t0->operand[0];
assert(INDR_REF == adj_addr->oprclass);
if (NULL != (t1 = (adj_addr = adj_addr->oprval.indr)->oprval.tref))
{ /* need to adjust target; NOTE assignments above */
if (OC_BOOLFINI != t1->opcode)
{ /* not past the end of the new chain */
assert(TJMP_REF == adj_addr->oprclass);
if ((t == t1) || (t1 == ref0))
ref1 = ref0; /* adjust to end of boolean expression */
else
{ /* old target should have jmplist entry */
/* from the jmp jmplisted in the old target we move past the next
* test (or NOOP) and jmp which correspond to the old target and pick
* the subsequent test (or NOOP) and jmp which correspond to those that originally followed
* the logic after the old target and are therefore the appropriate new target for this jmp
*/
assert(OC_NOOP == t1->opcode);
assert(&(t1->jmplist) != t1->jmplist.que.fl);
assert(NULL != t1->jmplist.bpt);
assert(oc_tab[t1->jmplist.bpt->opcode].octype & OCT_JUMP);
ref1 = t1->jmplist.bpt->exorder.fl;
assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_NOOP == ref1->opcode));
assert(oc_tab[ref1->exorder.fl->opcode].octype & OCT_JUMP);
ref1 = ref1->exorder.fl->exorder.fl;
assert((oc_tab[ref1->opcode].octype & OCT_BOOL) || (OC_BOOLFINI == ref1->opcode)
|| ((OC_NOOP == ref1->opcode) && ((OC_JMPTCLR == ref1->exorder.fl->opcode)
|| (OC_JMPTSET == ref1->exorder.fl->opcode)
|| (TREF(curtchain) == ref1->exorder.fl))));
}
t0->operand[0] = put_tjmp(ref1); /* no indrection simplifies later interations */
}
}
t0 = t0->exorder.fl;
if ((OC_BOOLFINI == t0->opcode) || (TREF(curtchain) == t0->exorder.fl))
break;
assert((oc_tab[t0->opcode].octype & OCT_BOOL)
|| (OC_JMPTSET == t0->exorder.fl->opcode) || (OC_JMPTCLR == t0->exorder.fl->opcode));
}
dqloop(TREF(bool_targ_ptr), que, tripbp) /* clean up borrowed jmplist entries */
{
dqdel(tripbp, que);
tripbp->bpt = NULL;
}
int m_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;
}
