/*------------------------------------------------------------------------*/
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_); }}}
_NIL_TYPE_ _reclaim_(const _UNS_TYPE_ mrg)
{ STATUS = DISABLED;
_PICO_RECLAIM_(_RECLAIM_YES_);
CTX_CAPTURE(SES_IDX);
_mem_reclaim_(mrg);
CTX_RESTORE(SES_IDX);
GLOBAL = _ag_get_TAB_EXP_(ROOT, GLOBAL_ROOT);
_NAMES_ = _ag_get_TAB_EXP_(ROOT, NAMES_ROOT);
ENVIRONMENT = _ag_get_TAB_EXP_(ROOT, ENVIRONMENT_ROOT);
_nat_reset_();
_PICO_RECLAIM_(_RECLAIM_NO_);
STATUS = ENABLED; }
/*----------------------------------------------------------------------------*/
static _NIL_TYPE_ INIC(_NIL_TYPE_)
{ _EXP_TYPE_ dct, exp, nbr, ltab, concreteTab, val;
_UNS_TYPE_ ctr, siz;
_stk_pop_EXP_(val);
_stk_pop_EXP_(nbr);
_stk_peek_EXP_(concreteTab);
siz = _ag_get_TAB_SIZ_(concreteTab);
ctr = _ag_get_NBU_(nbr);
_ag_set_TAB_EXP_(concreteTab, ctr, val);
if (ctr < siz)
{ nbr = _ag_succ_NBR_(nbr);
ctr = _ag_get_NBU_(nbr);
_stk_push_EXP_(nbr);
exp = _ag_get_TAB_EXP_(concreteTab, ctr);
_stk_push_EXP_(exp);
_stk_push_CNT_(EXP); }
else
{ _stk_zap_EXP_();
_stk_pop_EXP_(exp);
_stk_pop_EXP_(ltab);
_stk_peek_EXP_(dct);
_ag_set_DCT_VAL_(dct, ltab);
_ag_set_DCT_DCT_(dct, _DCT_);
_DCT_ = dct;
_ag_set_LTAB_CONCR_(ltab, concreteTab);
_ag_set_LTAB_LZEXP_(ltab, exp);
_ag_set_LTAB_DCT_(ltab, _DCT_);
_stk_poke_EXP_(ltab);
_stk_zap_CNT_(); }}
/*--------------------------------------------------------------------------*/
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_ 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; }}
_EXP_TYPE_ _env_make_NAM_(const _STR_TYPE_ str)
{ _SIZ_TYPE_ idx;
_EXP_TYPE_ nam;
for (idx = 1; idx < DCT_top; idx++)
{ nam = _ag_get_TAB_EXP_(_NAMES_, idx);
if (!strcmp(str, _ag_get_TXT_(nam)))
return nam; }
if (DCT_top > DCT_siz)
_error_(_DCT_ERROR_);
nam = _ag_make_TXT_(str);
_ag_set_TAB_EXP_(_NAMES_, DCT_top++, nam);
return nam; }
_NIL_TYPE_ _env_load_(const _EXP_TYPE_ env)
{ _EXP_TYPE_ bot, exp, stk, top;
_UNS_TYPE_ adr, idx, lwn, siz_1, siz_2, upn_1, upn_2;
siz_1 = _ag_get_TAB_SIZ_(_STK_); // jdk: stack sizes can differ
_DCT_ = _ag_get_ENV_DCT_(env);
bot = _ag_get_ENV_BOT_(env);
top = _ag_get_ENV_TOP_(env);
lwn = _ag_get_NBU_(bot);
upn_1 = _ag_get_NBU_(top);
stk = _ag_get_ENV_TAB_(env);
siz_2 = _ag_get_TAB_SIZ_(stk);
upn_2 = (siz_1 - siz_2 + upn_1);
for (idx = 1 ; idx <= lwn ; idx++)
{ exp = _ag_get_TAB_EXP_(stk, idx);
_ag_set_TAB_EXP_(_STK_, idx, exp); }
for (; idx < upn_2 ; idx++)
_ag_set_TAB_EXP_(_STK_, idx, _VOID_);
for (; idx <= siz_1 ; idx++)
{ exp = _ag_get_TAB_EXP_(stk, (idx + siz_2 - siz_1));
_ag_set_TAB_EXP_(_STK_, idx, exp); }
adr = (_UNS_TYPE_)_mem_cast_raw_(_STK_, _TAB_TAG_);
_EXP_ = adr + (lwn - 1)*_EXP_SIZE_;
_CNT_ = adr + (upn_2 - 1)*_EXP_SIZE_; }
_NIL_TYPE_ _env_expand_(_NIL_TYPE_)
{ _EXP_TYPE_ exp, stk;
_UNS_TYPE_ adr, idx, lwn, siz, upn, xsz;
siz = _ag_get_TAB_SIZ_(_STK_);
xsz = 2*siz;
if (xsz > _STK_MAX_)
_error_(_STK_ERROR_);
_mem_claim_SIZ_(xsz);
adr = (_UNS_TYPE_)_mem_cast_raw_(_STK_, _TAB_TAG_);
lwn = 1 + (_EXP_ - adr)/_EXP_SIZE_;
upn = 1 + (_CNT_ - adr)/_EXP_SIZE_;
stk = _ag_make_TAB_(xsz);
for (idx = 1 ; idx <= lwn ; idx++)
{ exp = _ag_get_TAB_EXP_(_STK_, idx);
_ag_set_TAB_EXP_(stk, idx, exp); }
for (idx = siz ; idx >= upn ; idx--)
{ exp = _ag_get_TAB_EXP_(_STK_, idx);
_ag_set_TAB_EXP_(stk, xsz--, exp); }
for ( ; xsz > lwn ; xsz--)
_ag_set_TAB_EXP_(stk, xsz, _VOID_);
adr = (_UNS_TYPE_)_mem_cast_raw_(stk, _TAB_TAG_);
_EXP_ = adr + (lwn - 1)*_EXP_SIZE_;
_CNT_ = adr + (upn + siz - 1)*_EXP_SIZE_;
_STK_ = stk; }
_NIL_TYPE_ _env_save_(const _EXP_TYPE_ env)
{ _EXP_TYPE_ bot, exp, stk, top;
_UNS_TYPE_ adr, idx, lwn, siz, upn;
siz = _ag_get_TAB_SIZ_(_STK_);
// _mem_claim_SIZ_(siz); // dvd: would corrupt, cfr CLL
adr = (_UNS_TYPE_)_mem_cast_raw_(_STK_, _TAB_TAG_);
lwn = 1 + (_EXP_ - adr)/_EXP_SIZE_;
upn = 1 + (_CNT_ - adr)/_EXP_SIZE_;
bot = _ag_make_NBU_(lwn);
top = _ag_make_NBU_(upn);
stk = _ag_make_TAB_(siz);
for (idx = 1 ; idx <= siz ; idx++)
{ exp = _ag_get_TAB_EXP_(_STK_, idx);
_ag_set_TAB_EXP_(stk, idx, exp); }
_ag_set_ENV_DCT_(env, _DCT_);
_ag_set_ENV_BOT_(env, bot);
_ag_set_ENV_TOP_(env, top);
_ag_set_ENV_TAB_(env, stk); }
/*--------------------------------------------------------------------------*/
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_); }
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ REF(_NIL_TYPE_)
{ _EXP_TYPE_ exp, nbr, tab;
_UNS_TYPE_ ctr, siz;
_TAG_TYPE_ tag;
_stk_pop_EXP_(nbr);
_stk_peek_EXP_(tab);
tag = _ag_get_TAG_(tab);
if (TAB_tab[tag])
{ siz = _ag_get_TAB_SIZ_(tab);
tag = _ag_get_TAG_(nbr);
if (tag == _NBR_TAG_)
{ ctr = _ag_get_NBU_(nbr);
if ((ctr > 0) && (ctr <= siz))
{ exp = _ag_get_TAB_EXP_(tab, ctr);
_stk_poke_EXP_(exp);
_stk_zap_CNT_(); }
else
_error_(_RNG_ERROR_); }
else
_error_(_IIX_ERROR_); }
else
_error_(_NAT_ERROR_); }
/*------------------------------------------------------------------------*/
static _NIL_TYPE_ ATA(_NIL_TYPE_)
{ _EXP_TYPE_ act, apl, arg, dct, exp, fun, nam, nbr, par, tab;
_CNT_TYPE_ cnt;
_UNS_TYPE_ ctr, siz;
_mem_claim_();
fun = _ag_make_FUN_();
_stk_pop_EXP_(apl);
_stk_pop_EXP_(nbr);
_stk_pop_EXP_(tab);
_stk_pop_EXP_(arg);
_stk_peek_EXP_(dct);
siz = _ag_get_TAB_SIZ_(arg);
ctr = _ag_get_NBU_(nbr);
act = _ag_get_TAB_EXP_(arg, ctr);
nam = _ag_get_APL_NAM_(apl);
par = _ag_get_APL_ARG_(apl);
_ag_set_FUN_NAM_(fun, nam);
_ag_set_FUN_ARG_(fun, par);
_ag_set_FUN_EXP_(fun, act);
_ag_set_FUN_DCT_(fun, _DCT_);
_ag_set_TAB_EXP_(tab, ctr, fun);
if (ctr < siz)
{ _stk_push_EXP_(arg);
_stk_push_EXP_(tab);
nbr = _ag_succ_NBR_(nbr);
_stk_push_EXP_(nbr);
_stk_push_EXP_(apl); }
else
{ _ag_set_DCT_VAL_(dct, tab);
_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; }}
/*------------------------------------------------------------------------*/
_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)); }}}
/*-------------------------------------------------------------------------*/
static _NIL_TYPE_ LRPL(_NIL_TYPE_)
{ _EXP_TYPE_ dct, arg, xdc, exp, nbr, tab, ltab, newtab, i;
_UNS_TYPE_ ctr, siz, pos;
_STR_TYPE_ iname;
_TAG_TYPE_ tag;
_stk_pop_EXP_(arg);
_stk_pop_EXP_(exp);
_stk_peek_EXP_(ltab);
tag = _ag_get_TAG_(arg);
if (tag == _VOI_TAG_) // Assign the new lazy expression
{ _ag_set_LTAB_LZEXP_(ltab, exp);
_ag_set_LTAB_DCT_(ltab, _DCT_);
_stk_zap_CNT_(); }
else if (TAB_tab[tag] && (_ag_get_TAB_SIZ_(arg) == 1)) // Assign new member of concrete part
{ tab = _ag_get_LTAB_CONCR_(ltab);
siz = _ag_get_TAB_SIZ_(tab);
nbr = _ag_get_TAB_EXP_(arg, 1);
tag = _ag_get_TAG_(nbr);
if (tag == _NBR_TAG_)
{ xdc = _ag_get_LTAB_DCT_(ltab);
pos = _ag_get_NBU_(nbr);
iname = "i";
_mem_claim_STR_(iname);
i = _env_make_NAM_(iname);
dct = _ag_make_DCT_();
_ag_set_DCT_NAM_(dct, i);
_ag_set_DCT_VAL_(dct, nbr);
_ag_set_DCT_DCT_(dct, xdc);
_stk_poke_EXP_(_DCT_);
_DCT_ = dct;
_stk_push_EXP_(exp);
_stk_push_EXP_(tab);
if ((pos > 0) && (pos <= 1073741824)) // greatest positive number represented with 31 bits, greater are negative
{ if (pos > siz)
{ ctr = _ag_get_NBU_(nbr); // make the counter equal to pos
_mem_claim_SIZ_(ctr); // create a new concrete table
newtab = _ag_make_TAB_(ctr);
_ag_set_LTAB_CONCR_(ltab, newtab);
exp = _ag_make_LAZY_(); // fill the new concrete table
while (ctr > siz) { // first fill with <lazy> members
_ag_set_TAB_EXP_(newtab, ctr, exp);
ctr--; }
while (ctr > 0) { // now copy the concrete part
exp = _ag_get_TAB_EXP_(tab, ctr);
_ag_set_TAB_EXP_(newtab, ctr, exp);
ctr--; }
_stk_poke_EXP_(newtab);
}
_stk_pop_EXP_(tab);
_stk_peek_EXP_(exp);
_stk_poke_EXP_(tab);
_stk_push_EXP_(nbr);
_stk_push_EXP_(exp);
_stk_poke_CNT_(ATL);
_stk_push_CNT_(EXP);
}
else
_error_(_RNG_ERROR_); }
else
_error_(_IIX_ERROR_); }
else
_error_(_IAG_ERROR_); }
