/*------------------------------------------------------------------------*/ 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_ 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_ 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_ 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_ _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_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_ RPL(_NIL_TYPE_) { _EXP_TYPE_ nbr, tab, val; _UNS_TYPE_ ctr, siz; _TAG_TYPE_ tag; _stk_pop_EXP_(nbr); _stk_pop_EXP_(val); _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)) { _ag_set_TAB_EXP_(tab, ctr, val); _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_ _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_ _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_); }