/*--------------------------------------------------------------------------*/
static _NIL_TYPE_ LARG(_NIL_TYPE_)
{ _EXP_TYPE_ dct, exp, val, ltab;
_TAG_TYPE_ tag;
_stk_claim_();
_stk_pop_EXP_(val);
tag = _ag_get_TAG_(val);
if (tag == _VOI_TAG_)
{ _stk_pop_EXP_(exp);
ltab = _ag_make_LTAB_();
_stk_peek_EXP_(dct);
_ag_set_DCT_VAL_(dct, ltab);
_ag_set_DCT_DCT_(dct, _DCT_);
_DCT_ = dct;
_ag_set_LTAB_CONCR_(ltab, _EMPTY_);
_ag_set_LTAB_LZEXP_(ltab, exp);
_ag_set_LTAB_DCT_(ltab, _DCT_);
_stk_poke_EXP_(ltab);
_stk_zap_CNT_(); }
else if (tag == _TAB_TAG_)
{ ltab = _ag_make_LTAB_();
_stk_peek_EXP_(exp);
_stk_poke_EXP_(ltab);
_stk_push_EXP_(exp);
_stk_push_EXP_(val);
_stk_push_EXP_(_ONE_);
exp = _ag_get_TAB_EXP_(val, 1);
_stk_push_EXP_(exp);
_stk_poke_CNT_(INIC);
_stk_push_CNT_(EXP); }
else
_error_(_IAG_ERROR_); }
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ INI(_NIL_TYPE_)
{ _EXP_TYPE_ dct, exp, nbr, tab, val;
_UNS_TYPE_ ctr, siz;
_stk_claim_();
_stk_pop_EXP_(val);
_stk_pop_EXP_(nbr);
_stk_pop_EXP_(exp);
_stk_peek_EXP_(tab);
siz = _ag_get_TAB_SIZ_(tab);
ctr = _ag_get_NBU_(nbr);
_ag_set_TAB_EXP_(tab, ctr, val);
if (ctr < siz)
{ nbr = _ag_succ_NBR_(nbr);
_stk_push_EXP_(exp);
_stk_push_EXP_(nbr);
_stk_push_EXP_(exp);
_stk_push_CNT_(EXP); }
else
{ _stk_zap_EXP_();
_stk_peek_EXP_(dct);
_ag_set_DCT_VAL_(dct, tab);
_ag_set_DCT_DCT_(dct, _DCT_);
_DCT_ = dct;
_stk_poke_EXP_(tab);
_stk_zap_CNT_(); }}
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ IDX(_NIL_TYPE_)
{ _EXP_TYPE_ dct, exp, nbr, tab;
_TAG_TYPE_ tag;
_UNS_TYPE_ siz;
_stk_claim_();
_stk_pop_EXP_(nbr);
tag = _ag_get_TAG_(nbr);
if (tag == _NBR_TAG_)
{ siz = _ag_get_NBU_(nbr);
if (siz == 0)
{ _stk_zap_EXP_();
_stk_peek_EXP_(dct);
_ag_set_DCT_VAL_(dct, _EMPTY_);
_ag_set_DCT_DCT_(dct, _DCT_);
_DCT_ = dct;
_stk_poke_EXP_(_EMPTY_);
_stk_zap_CNT_(); }
else if (siz > 0)
{ _mem_claim_SIZ_(siz);
tab = _ag_make_TAB_(siz);
_stk_peek_EXP_(exp);
_stk_poke_EXP_(tab);
_stk_push_EXP_(exp);
_stk_push_EXP_(_ONE_);
_stk_push_EXP_(exp);
_stk_poke_CNT_(INI);
_stk_push_CNT_(EXP); }
else
_error_(_SIZ_ERROR_);}
else
_error_(_SIZ_ERROR_); }
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ ATV(_NIL_TYPE_)
{ _EXP_TYPE_ act, arg, dct, exp, nbr, tab, val;
_CNT_TYPE_ cnt;
_UNS_TYPE_ ctr, siz;
_stk_claim_();
_stk_pop_EXP_(val);
_stk_pop_EXP_(nbr);
_stk_pop_EXP_(tab);
_stk_peek_EXP_(arg);
siz = _ag_get_TAB_SIZ_(arg);
ctr = _ag_get_NBU_(nbr);
_ag_set_TAB_EXP_(tab, ctr, val);
if (ctr < siz)
{ act = _ag_get_TAB_EXP_(arg, ctr+1);
_stk_push_EXP_(tab);
nbr = _ag_succ_NBR_(nbr);
_stk_push_EXP_(nbr);
_stk_push_EXP_(act);
_stk_push_CNT_(EXP); }
else
{ _stk_zap_EXP_();
_stk_pop_EXP_(dct);
_ag_set_DCT_VAL_(dct, tab);
_stk_zap_CNT_();
_stk_peek_CNT_(cnt);
if (cnt != RET)
{ _stk_peek_EXP_(exp);
_stk_poke_EXP_(_DCT_);
_stk_push_EXP_(exp);
_stk_push_CNT_(RET); }
_stk_push_CNT_(EXP);
_DCT_ = dct; }}
static _NIL_TYPE_ APL(_NIL_TYPE_)
{ _EXP_TYPE_ apl, arg, dct, fun, nam, nbr;
_TAG_TYPE_ tag;
_stk_claim_();
_stk_peek_EXP_(apl);
nam = _ag_get_APL_NAM_(apl);
arg = _ag_get_APL_ARG_(apl);
_dct_locate_(nam, dct, _DCT_);
fun = _ag_get_DCT_VAL_(dct);
tag = _ag_get_TAG_(fun);
switch (tag)
{ case _FUN_TAG_:
_stk_poke_EXP_(fun);
_stk_poke_CNT_(CAL);
break;
case _NAT_TAG_:
nbr = _ag_get_NAT_NBR_(fun);
_stk_poke_EXP_(nbr);
_stk_poke_CNT_(NAT);
break;
default:
_error_msg_(_NAF_ERROR_, nam); }
_stk_push_EXP_(arg);
tag = _ag_get_TAG_(arg);
if (tag != _TAB_TAG_)
_stk_push_CNT_(EXP); }
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ SET(_NIL_TYPE_)
{ _EXP_TYPE_ arg, dct, exp, fun, idx, inv, nam, set, tab, ltab;
_TAG_TYPE_ tag;
_stk_claim_();
_mem_claim_();
_stk_peek_EXP_(set);
inv = _ag_get_SET_INV_(set);
exp = _ag_get_SET_EXP_(set);
tag = _ag_get_TAG_(inv);
switch (tag)
{ case _VAR_TAG_:
nam = _ag_get_VAR_NAM_(inv);
_dct_locate_(nam, dct, _DCT_);
_stk_poke_EXP_(dct);
_stk_push_EXP_(exp);
_stk_poke_CNT_(CHG);
_stk_push_CNT_(EXP);
break;
case _APL_TAG_:
fun = _ag_make_FUN_();
inv = _ag_get_SET_INV_(set);
nam = _ag_get_APL_NAM_(inv);
arg = _ag_get_APL_ARG_(inv);
_dct_locate_(nam, dct, _DCT_);
_ag_set_DCT_VAL_(dct, fun);
_ag_set_FUN_NAM_(fun, nam);
_ag_set_FUN_ARG_(fun, arg);
_ag_set_FUN_EXP_(fun, exp);
_ag_set_FUN_DCT_(fun, _DCT_);
_stk_poke_EXP_(fun);
_stk_zap_CNT_();
break;
case _TBL_TAG_:
nam = _ag_get_TBL_NAM_(inv);
idx = _ag_get_TBL_IDX_(inv);
_dct_locate_(nam, dct, _DCT_);
tab = _ag_get_DCT_VAL_(dct);
_stk_poke_EXP_(tab);
_stk_push_EXP_(idx);
_stk_push_EXP_(exp);
_stk_poke_CNT_(RPL);
_stk_push_CNT_(SWP);
_stk_push_CNT_(EXP);
break;
case _LTBL_TAG_:
nam = _ag_get_TBL_NAM_(inv);
arg = _ag_get_TBL_IDX_(inv);
_dct_locate_(nam, dct, _DCT_);
ltab = _ag_get_DCT_VAL_(dct);
_stk_poke_EXP_(ltab);
_stk_push_EXP_(exp);
_stk_push_EXP_(arg);
_stk_poke_CNT_(LRPL);
_stk_push_CNT_(EXP);
break;
default:
_error_(_AGR_ERROR_); }}
/*-------------------------------------------------------------------------*/
static _NIL_TYPE_ DEF(_NIL_TYPE_)
{ _EXP_TYPE_ arg, dct, def, exp, fun, idx, inv, nam;
_TAG_TYPE_ tag;
_stk_claim_();
_mem_claim_();
dct = _ag_make_DCT_();
_stk_peek_EXP_(def);
inv = _ag_get_DEF_INV_(def);
exp = _ag_get_DEF_EXP_(def);
tag = _ag_get_TAG_(inv);
switch (tag)
{ case _VAR_TAG_:
nam = _ag_get_VAR_NAM_(inv);
_ag_set_DCT_NAM_(dct, nam);
_stk_poke_EXP_(dct);
_stk_push_EXP_(exp);
_stk_poke_CNT_(ASS);
_stk_push_CNT_(EXP);
break;
case _APL_TAG_:
fun = _ag_make_FUN_();
nam = _ag_get_APL_NAM_(inv);
arg = _ag_get_APL_ARG_(inv);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_VAL_(dct, fun);
_ag_set_DCT_DCT_(dct, _DCT_);
_DCT_ = dct;
_ag_set_FUN_NAM_(fun, nam);
_ag_set_FUN_ARG_(fun, arg);
_ag_set_FUN_EXP_(fun, exp);
_ag_set_FUN_DCT_(fun, dct);
_stk_poke_EXP_(fun);
_stk_zap_CNT_();
break;
case _TBL_TAG_:
nam = _ag_get_TBL_NAM_(inv);
idx = _ag_get_TBL_IDX_(inv);
_ag_set_DCT_NAM_(dct, nam);
_stk_poke_EXP_(dct);
_stk_push_EXP_(exp);
_stk_push_EXP_(idx);
_stk_poke_CNT_(IDX);
_stk_push_CNT_(EXP);
break;
case _LTBL_TAG_: // Added Lazy Tabulation
nam = _ag_get_LTBL_NAM_(inv);
arg = _ag_get_LTBL_ARG_(inv);
_ag_set_DCT_NAM_(dct, nam);
_stk_poke_EXP_(dct);
_stk_push_EXP_(exp);
_stk_push_EXP_(arg);
_stk_poke_CNT_(LARG);
_stk_push_CNT_(EXP);
break;
default:
_error_(_AGR_ERROR_); }}
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ BND(_NIL_TYPE_)
{ _EXP_TYPE_ act, arg, dct, exp, fun, frm, nam, nbr, par, val, xdc;
_CNT_TYPE_ cnt;
_TAG_TYPE_ tag;
_UNS_TYPE_ ctr, siz;
_stk_claim_();
_mem_claim_();
_stk_pop_EXP_(val);
_stk_pop_EXP_(dct);
_ag_set_DCT_VAL_(dct, val);
_stk_pop_EXP_(nbr);
_stk_pop_EXP_(arg);
siz = _ag_get_TAB_SIZ_(arg);
ctr = _ag_get_NBU_(nbr);
if (ctr == siz)
{ _stk_zap_EXP_();
_stk_zap_CNT_();
_stk_peek_CNT_(cnt);
if (cnt != RET)
{ _stk_peek_EXP_(exp);
_stk_poke_EXP_(_DCT_);
_stk_push_EXP_(exp);
_stk_push_CNT_(RET); }
_stk_push_CNT_(EXP);
_DCT_ = dct; }
else
{ _stk_peek_EXP_(par);
frm = _ag_get_TAB_EXP_(par, ++ctr);
act = _ag_get_TAB_EXP_(arg, ctr);
tag = _ag_get_TAG_(frm);
_stk_push_EXP_(arg);
nbr = _ag_succ_NBR_(nbr);
_stk_push_EXP_(nbr);
xdc = _ag_make_DCT_();
_stk_push_EXP_(xdc);
_ag_set_DCT_DCT_(xdc, dct);
switch (tag)
{ case _VAR_TAG_:
nam = _ag_get_VAR_NAM_(frm);
_ag_set_DCT_NAM_(xdc, nam);
_stk_push_EXP_(act);
_stk_push_CNT_(EXP);
break;
case _APL_TAG_:
fun = _ag_make_FUN_();
nam = _ag_get_APL_NAM_(frm);
arg = _ag_get_APL_ARG_(frm);
_ag_set_DCT_NAM_(xdc, nam);
_ag_set_FUN_NAM_(fun, nam);
_ag_set_FUN_ARG_(fun, arg);
_ag_set_FUN_EXP_(fun, act);
_ag_set_FUN_DCT_(fun, _DCT_);
_stk_push_EXP_(fun);
break;
default:
_error_(_IPM_ERROR_); }}}
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ TBL(_NIL_TYPE_)
{ _EXP_TYPE_ dct, idx, nam, tab, tbl;
_stk_claim_();
_stk_peek_EXP_(tbl);
nam = _ag_get_TBL_NAM_(tbl);
idx = _ag_get_TBL_IDX_(tbl);
_dct_locate_(nam, dct, _DCT_);
tab = _ag_get_DCT_VAL_(dct);
_stk_poke_EXP_(tab);
_stk_push_EXP_(idx);
_stk_poke_CNT_(REF);
_stk_push_CNT_(EXP); }
_RES_TYPE_ _PICO_ACCEPT_(const _SES_TYPE_ ses,
const _STR_TYPE_ str)
{ if (STATUS != ENABLED)
return _CTL_ERROR_;
for (SES_IDX = 0 ; SES_IDX < _MAX_SES_ ; SES_IDX++)
if (SES_TAB[SES_IDX].ses == ses)
{ if (SES_TAB[SES_IDX].res != _DO_ACCEPT_)
return _CTL_ERROR_;
CTX_RESTORE(SES_IDX);
_stk_claim_();
_mem_claim_STR_(str);
_stk_push_EXP_(_ag_make_TXT_(str));
_ESC_ = SES_TAB[SES_IDX].esc;
if (setjmp(SES_TAB[SES_IDX].exi) == 0)
_stk_loop_();
CTX_CAPTURE(SES_IDX);
return SES_TAB[SES_IDX].res; }
return _SNA_ERROR_; }
/*--------------------------------------------------------------------------*/
static _NIL_TYPE_ LTBL(_NIL_TYPE_)
{ _EXP_TYPE_ dct, idx, val, nam, ltab, ltbl;
_TAG_TYPE_ tag;
_stk_claim_();
_stk_peek_EXP_(ltbl);
nam = _ag_get_TBL_NAM_(ltbl);
val = _ag_get_TBL_IDX_(ltbl);
tag = _ag_get_TAG_(val);
if (tag == _TAB_TAG_)
{ idx = _ag_get_TAB_EXP_(val, 1);
_dct_locate_(nam, dct, _DCT_);
ltab = _ag_get_DCT_VAL_(dct);
_stk_poke_EXP_(ltab);
_stk_push_EXP_(idx);
_stk_poke_CNT_(LREF);
_stk_push_CNT_(EXP); }
else
_error_(_IIX_ERROR_); }
/*------------------------------------------------------------------------*/
_NIL_TYPE_ _eval_CAL_(_NIL_TYPE_)
{ _EXP_TYPE_ act, arg, dct, exp, frm, fun, nam, par, tab, xdc, xfu;
_CNT_TYPE_ cnt;
_TAG_TYPE_ tag, xtg;
_UNS_TYPE_ siz, xsz;
_stk_claim_();
_stk_peek_EXP_(arg);
tag = _ag_get_TAG_(arg);
if (tag != _TAB_TAG_)
{ _stk_zap_EXP_();
_stk_peek_EXP_(fun);
_error_msg_(_NAT_ERROR_, _ag_get_FUN_NAM_(fun)); }
siz = _ag_get_TAB_SIZ_(arg);
_mem_claim_SIZ_(siz);
_stk_pop_EXP_(arg);
if (siz == 0)
{ _stk_peek_EXP_(fun);
par = _ag_get_FUN_ARG_(fun);
tag = _ag_get_TAG_(par);
switch (tag)
{ case _VAR_TAG_:
case _APL_TAG_:
dct = _ag_make_DCT_();
par = _ag_get_FUN_ARG_(fun);
nam = _ag_get_VAR_NAM_(par);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_VAL_(dct, _EMPTY_);
xdc = _ag_get_FUN_DCT_(fun);
_ag_set_DCT_DCT_(dct, xdc);
break;
case _TAB_TAG_:
xsz = _ag_get_TAB_SIZ_(par);
if (xsz == 0)
dct = _ag_get_FUN_DCT_(fun);
else
_error_msg_(_NMA_ERROR_, _ag_get_FUN_NAM_(fun));
break;
default:
_error_msg_(_IPM_ERROR_, _ag_get_FUN_NAM_(fun)); }
exp = _ag_get_FUN_EXP_(fun);
_stk_zap_CNT_();
_stk_peek_CNT_(cnt);
if (cnt != RET)
{ _stk_poke_EXP_(_DCT_);
_stk_push_EXP_(exp);
_stk_push_CNT_(RET); }
else
_stk_poke_EXP_(exp);
_stk_push_CNT_(EXP);
_DCT_ = dct; }
else
{ dct = _ag_make_DCT_();
_stk_peek_EXP_(fun);
par = _ag_get_FUN_ARG_(fun);
exp = _ag_get_FUN_EXP_(fun);
xdc = _ag_get_FUN_DCT_(fun);
tag = _ag_get_TAG_(par);
switch (tag)
{ case _VAR_TAG_:
nam = _ag_get_VAR_NAM_(par);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_DCT_(dct, xdc);
_stk_poke_EXP_(exp);
_stk_push_EXP_(dct);
_stk_push_EXP_(arg);
tab = _ag_make_TAB_(siz);
act = _ag_get_TAB_EXP_(arg, 1);
_stk_push_EXP_(tab);
_stk_push_EXP_(_ONE_);
_stk_push_EXP_(act);
_stk_poke_CNT_(ATV);
_stk_push_CNT_(EXP);
break;
case _APL_TAG_:
nam = _ag_get_APL_NAM_(par);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_DCT_(dct, xdc);
_stk_poke_EXP_(exp);
_stk_push_EXP_(dct);
_stk_push_EXP_(arg);
tab = _ag_make_TAB_(siz);
_stk_push_EXP_(tab);
_stk_push_EXP_(_ONE_);
_stk_push_EXP_(par);
_stk_poke_CNT_(ATA);
break;
case _TAB_TAG_:
xsz = _ag_get_TAB_SIZ_(par);
if (siz != xsz)
_error_msg_(_NMA_ERROR_, _ag_get_FUN_NAM_(fun));
frm = _ag_get_TAB_EXP_(par, 1);
xtg = _ag_get_TAG_(frm);
switch (xtg)
{ case _VAR_TAG_:
act = _ag_get_TAB_EXP_(arg, 1);
_stk_poke_EXP_(exp);
_stk_push_EXP_(par);
_stk_push_EXP_(arg);
_stk_push_EXP_(_ONE_);
nam = _ag_get_VAR_NAM_(frm);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_DCT_(dct, xdc);
_stk_push_EXP_(dct);
_stk_push_EXP_(act);
_stk_poke_CNT_(BND);
_stk_push_CNT_(EXP);
break;
case _APL_TAG_:
xfu = _ag_make_FUN_();
par = _ag_get_FUN_ARG_(fun);
exp = _ag_get_FUN_EXP_(fun);
xdc = _ag_get_FUN_DCT_(fun);
act = _ag_get_TAB_EXP_(arg, 1);
frm = _ag_get_TAB_EXP_(par, 1);
_stk_poke_EXP_(exp);
_stk_push_EXP_(par);
_stk_push_EXP_(arg);
_stk_push_EXP_(_ONE_);
nam = _ag_get_APL_NAM_(frm);
arg = _ag_get_APL_ARG_(frm);
_ag_set_DCT_NAM_(dct, nam);
_ag_set_DCT_DCT_(dct, xdc);
_stk_push_EXP_(dct);
_ag_set_FUN_NAM_(xfu, nam);
_ag_set_FUN_ARG_(xfu, arg);
_ag_set_FUN_EXP_(xfu, act);
_ag_set_FUN_DCT_(xfu, _DCT_);
_stk_push_EXP_(xfu);
_stk_poke_CNT_(BND);
break;
default:
_error_msg_(_IPM_ERROR_, _ag_get_FUN_NAM_(fun)); }
break;
default:
_error_msg_(_IPM_ERROR_, _ag_get_FUN_NAM_(fun)); }}}
