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;
}
int comp_fini(bool status, mstr *obj, opctype retcode, oprtype *retopr, int src_len)
{
triple *ref;
error_def(ERR_INDEXTRACHARS);
if (status && source_column != src_len + 2 && source_buffer[source_column] != '\0')
{
status = FALSE;
stx_error(ERR_INDEXTRACHARS);
}
if (status)
{
cg_phase = CGP_RESOLVE;
assert(for_stack_ptr == for_stack);
if (*for_stack_ptr)
tnxtarg(*for_stack_ptr);
ref = newtriple(retcode);
if (retopr)
ref->operand[0] = *retopr;
start_fetches(OC_NOOP);
resolve_ref(0); /* cannot fail because there are no MLAB_REF's in indirect code */
alloc_reg();
stp_gcol(0);
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
compile_time = FALSE;
ind_code(obj);
indr_stringpool.free = indr_stringpool.base;
}
else
{
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
indr_stringpool.free = indr_stringpool.base;
compile_time = FALSE;
cg_phase = CGP_NOSTATE;
}
transform = TRUE;
mcfree();
return status;
}
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 comp_fini(int status, mstr *obj, opctype retcode, oprtype *retopr, oprtype *dst, mstr_len_t src_len)
{
triple *ref;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
if (status)
{
while (TK_SPACE == TREF(window_token)) /* Eat up trailing white space */
advancewindow();
if (TK_ERROR == TREF(window_token))
{
status = EXPR_FAIL;
stx_error(ERR_INDRCOMPFAIL);
} else if ((TK_EOL != TREF(window_token)) || (source_column < src_len))
{
status = EXPR_FAIL;
stx_error(ERR_INDEXTRACHARS);
} else
{
cg_phase = CGP_RESOLVE;
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (*TREF(for_stack_ptr))
tnxtarg(*TREF(for_stack_ptr));
ref = newtriple(retcode);
if (retopr)
ref->operand[0] = *retopr;
if (OC_IRETMVAL == retcode)
ref->operand[1] = *dst;
start_fetches(OC_NOOP);
resolve_ref(0); /* cannot fail because there are no MLAB_REF's in indirect code */
alloc_reg();
INVOKE_STP_GCOL(0);
/* The above invocation of stp_gcol with a parameter of 0 is a critical part of compilation
* (both routine compilations and indirect dynamic compilations). This collapses the indirect
* (compilation) stringpool so that only the literals are left. This stringpool is then written
* out to the compiled object as the literal pool for that compilation. Temporary stringpool
* use for conversions or whatever are eliminated. Note the path is different in stp_gcol for
* the indirect stringpool which is only used during compilations.
*/
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
TREF(compile_time) = FALSE;
ind_code(obj);
indr_stringpool.free = indr_stringpool.base;
}
} else
{ /* If this assert fails, it means a syntax problem could have been caught earlier. Consider placing a more useful
* and specific error message at that location.
*/
assert(FALSE);
stx_error(ERR_INDRCOMPFAIL);
}
if (EXPR_FAIL == status)
{
assert(indr_stringpool.base == stringpool.base);
indr_stringpool = stringpool;
stringpool = rts_stringpool;
indr_stringpool.free = indr_stringpool.base;
TREF(compile_time) = FALSE;
cg_phase = CGP_NOSTATE;
}
TREF(transform) = TRUE;
COMPILE_HASHTAB_CLEANUP;
mcfree();
return status;
}
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;
}
boolean_t line(uint4 *lnc)
{
boolean_t success;
int parmcount, varnum;
short int dot_count;
mlabel *x;
mline *curlin;
triple *first_triple, *parmbase, *parmtail, *r;
DCL_THREADGBL_ACCESS;
SETUP_THREADGBL_ACCESS;
first_triple = (TREF(curtchain))->exorder.bl;
dot_count = 0;
parmbase = NULL;
success = TRUE;
curlin = (mline *)mcalloc(SIZEOF(*curlin));
curlin->line_number = 0;
curlin->table = FALSE;
TREF(last_source_column) = 0;
if (TK_INTLIT == TREF(window_token))
int_label();
if ((TK_IDENT == TREF(window_token)) || (cmd_qlf.qlf & CQ_LINE_ENTRY))
start_fetches(OC_LINEFETCH);
else
newtriple(OC_LINESTART);
curlin->line_number = *lnc;
*lnc = *lnc + 1;
curlin->table = TRUE;
CHKTCHAIN(TREF(curtchain));
TREF(pos_in_chain) = *(TREF(curtchain));
if (TK_IDENT == TREF(window_token))
{
x = get_mladdr(&(TREF(window_ident)));
if (x->ml)
{
stx_error(ERR_MULTLAB);
success = FALSE;
} else
{
assert(NO_FORMALLIST == x->formalcnt);
x->ml = curlin;
advancewindow();
if (TK_COLON != TREF(window_token))
mlmax++;
else
{
x->gbl = FALSE;
advancewindow();
}
}
if (success && (TK_LPAREN == TREF(window_token)))
{
advancewindow();
parmbase = parmtail = newtriple(OC_BINDPARM);
for (parmcount = 0; TK_RPAREN != TREF(window_token); parmcount++)
{
if (TK_IDENT != TREF(window_token))
{
stx_error(ERR_NAMEEXPECTED);
success = FALSE;
break;
} else
{
varnum = get_mvaddr(&(TREF(window_ident)))->mvidx;
for (r = parmbase->operand[1].oprval.tref; r; r = r->operand[1].oprval.tref)
{
assert(TRIP_REF == r->operand[0].oprclass);
assert(ILIT_REF == r->operand[0].oprval.tref->operand[0].oprclass);
assert((TRIP_REF == r->operand[1].oprclass) || (0 == r->operand[1].oprclass));
if (r->operand[0].oprval.tref->operand[0].oprval.ilit == varnum)
{
stx_error(ERR_MULTFORMPARM);
success = FALSE;
break;
}
}
if (!success)
break;
r = newtriple(OC_PARAMETER);
parmtail->operand[1] = put_tref(r);
r->operand[0] = put_ilit(varnum);
parmtail = r;
advancewindow();
}
if (TK_COMMA == TREF(window_token))
advancewindow();
else if (TK_RPAREN != TREF(window_token))
{
stx_error(ERR_COMMAORRPAREXP);
success = FALSE;
break;
}
}
if (success)
{
advancewindow();
parmbase->operand[0] = put_ilit(parmcount);
x->formalcnt = parmcount;
assert(!mlabtab->lson);
if ((mlabtab->rson == x) && !TREF(code_generated))
mlabtab->formalcnt = parmcount;
}
}
}
if (success && (TK_EOL != TREF(window_token)))
{
if (TK_SPACE != TREF(window_token))
{
stx_error(ERR_LSEXPECTED);
success = FALSE;
} else
{
assert(0 == dot_count);
for (;;)
{
if (TK_SPACE == TREF(window_token))
advancewindow();
else if (TK_PERIOD == TREF(window_token))
{
dot_count++;
advancewindow();
} else
break;
}
}
if ((block_level + 1) < dot_count)
{
dot_count = (block_level > 0) ? block_level : 0;
stx_error(ERR_BLKTOODEEP);
success = FALSE;
}
}
if ((0 != parmbase) && (0 != dot_count))
{
stx_error(ERR_NESTFORMP); /* Should be warning */
success = FALSE;
dot_count = (block_level > 0 ? block_level : 0);
}
if ((block_level + 1) <= dot_count)
{
mline_tail->child = curlin;
curlin->parent = mline_tail;
block_level = dot_count;
} else
{
for (; dot_count < block_level; block_level--)
mline_tail = mline_tail->parent;
mline_tail->sibling = curlin;
curlin->parent = mline_tail->parent;
}
mline_tail = curlin;
if (success)
{
assert(TREF(for_stack_ptr) == TADR(for_stack));
*(TREF(for_stack_ptr)) = NULL;
success = linetail();
if (success)
{
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (*(TREF(for_stack_ptr)))
tnxtarg(*(TREF(for_stack_ptr)));
}
}
assert(TREF(for_stack_ptr) == TADR(for_stack));
if (first_triple->exorder.fl == TREF(curtchain))
newtriple(OC_NOOP); /* empty line (comment, blank, etc) */
curlin->externalentry = first_triple->exorder.fl;
/* First_triple points to the last triple before this line was processed. Its forward link will point to a
* LINEFETCH or a LINESTART, or possibly a NOOP. It the line was a comment, there is only a LINESTART, and
* hence no "real" code yet.
*/
TREF(code_generated) = TREF(code_generated) | ((OC_NOOP != first_triple->exorder.fl->opcode)
&& (first_triple->exorder.fl->exorder.fl != TREF(curtchain)));
return success;
}
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;
}
int m_if(void)
{
triple *ref0, *ref1, *ref2, *jmpref, ifpos_in_chain, *triptr;
oprtype x, y, *ta_opr;
bool first_time, t_set, is_commarg;
typedef struct jmpchntype
{ struct
{ struct jmpchntype *fl,*bl;
}link;
triple *jmptrip;
}jmpchn;
jmpchn *jmpchain,*nxtjmp;
error_def(ERR_SPOREOL);
error_def(ERR_INDEXTRACHARS);
ifpos_in_chain = pos_in_chain;
jmpchain = (jmpchn*) mcalloc(sizeof(jmpchn));
dqinit(jmpchain,link);
if (window_token == TK_EOL)
return TRUE;
is_commarg = last_source_column == 1;
x = for_end_of_scope(0);
assert(x.oprclass == INDR_REF);
if (window_token == TK_SPACE)
{ jmpref = newtriple(OC_JMPTCLR);
jmpref->operand[0] = x;
nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
nxtjmp->jmptrip = jmpref;
dqins(jmpchain,link,nxtjmp);
}
else
{
first_time = TRUE;
for (;;)
{
ta_opr = (oprtype *) mcalloc(sizeof(oprtype));
if (!bool_expr((bool) TRUE, ta_opr))
return FALSE;
if ((ref0 = curtchain->exorder.bl)->opcode == OC_JMPNEQ
&& (ref1 = ref0->exorder.bl)->opcode == OC_COBOOL
&& (ref2 = ref1->exorder.bl)->opcode == OC_INDGLVN)
{
dqdel(ref0,exorder);
ref1->opcode = OC_JMPTSET;
ref1->operand[0] = put_indr(ta_opr);
ref2->opcode = OC_COMMARG;
ref2->operand[1] = put_ilit((mint) indir_if);
}
t_set = curtchain->exorder.bl->opcode == OC_JMPTSET;
if (!t_set)
newtriple(OC_CLRTEST);
if (expr_start != expr_start_orig)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
}
jmpref = newtriple(OC_JMP);
jmpref->operand[0] = x;
nxtjmp = (jmpchn *) mcalloc(sizeof(jmpchn));
nxtjmp->jmptrip = jmpref;
dqins(jmpchain,link,nxtjmp);
tnxtarg(ta_opr);
if (first_time)
{
if (!t_set)
newtriple(OC_SETTEST);
if (expr_start != expr_start_orig)
{
triptr = newtriple(OC_GVRECTARG);
triptr->operand[0] = put_tref(expr_start);
}
first_time = FALSE;
}
if (window_token != TK_COMMA)
break;
advancewindow();
}
}
if (is_commarg)
{
if (window_token != TK_EOL)
{
stx_error(ERR_INDEXTRACHARS);
return FALSE;
}
return TRUE;
}
if (window_token != TK_EOL && window_token != TK_SPACE)
{
stx_error(ERR_SPOREOL);
return FALSE;
}
if (!linetail())
{ tnxtarg(&x);
dqloop(jmpchain,link,nxtjmp)
{ ref1 = nxtjmp->jmptrip;
ref1->operand[0] = x;
}
int 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;
}
