/* stack operator
**nest**
> Creates a fresh stack with current TOS on it. Saves current dstack onto
> rstack.
*/
bvm_cache *nest(bvm_cache *this_bvm){ // nest#
mword *nest_body = dstack_get(this_bvm,0);
// mword *new_stack = dstack_get(this_bvm,1);
mword *save_TOS = dstack_get(this_bvm,1);
popd(this_bvm);
popd(this_bvm);
mword *save_dstack = (mword*)icar(this_bvm->dstack_ptr);
mword *save_ustack = (mword*)icar(this_bvm->ustack_ptr);
clear(this_bvm); // clear the stack
//rgive(this_bvm, new_stack);
pushd(this_bvm, save_TOS, IMMORTAL);
mword *nest_return = (mword*)icdr(icar(this_bvm->code_ptr));
mword *nest_rstack_entry = consa2(this_bvm, save_dstack,
consa2(this_bvm, save_ustack,
consa2(this_bvm, nest_return, nil)));
pushr(this_bvm, nest_rstack_entry, _hash8(C2B("/babel/tag/nest")));
this_bvm->code_ptr = consa2(this_bvm, nest_body,nil);
icar(this_bvm->advance_type) = BVM_CONTINUE;
return this_bvm;
}
mword *inline_bpdl_hash_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_hash_list#
#ifdef BPDL_TRACE
_trace;
#endif
return _hash8( this_bvm, bpdl_quote_to_bstruct( this_bvm, (mword*)icar(sexpr) ) );
}
void inline_bpdl_sym_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_sym_list#
#ifdef BPDL_TRACE
_trace;
#endif
insym(this_bvm,
_hash8( this_bvm, bpdl_quote_to_bstruct( this_bvm, (mword*)icar(sexpr) ) ),
inline_bpdl( this_bvm, (mword*)icar((mword*)icdr(sexpr)) ));
}
mword *bpdl_lookup_label(bvm_cache *this_bvm, mword *label){ // bpdl_lookup_label#
if(bpdl_is_label_nil(label)){
return nil;
}
return
_cons( this_bvm,
lusym(this_bvm,
_hash8( this_bvm, _lf2by(this_bvm, label) )),
nil);
}
// XXX: This does not handle [tag "foo"] syntax for vals...
//
mword *inline_bpdl_tag_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_tag_list#
#ifdef BPDL_TRACE
_trace;
#endif
mword *tag = _hash8( this_bvm, bpdl_quote_to_bstruct( this_bvm, (mword*)icar(sexpr) ) );
// mword *pay = inline_bpdl( this_bvm, (mword*)icar((mword*)icdr(sexpr)) );
mword *pay = inline_bpdl( this_bvm, (mword*)icdr(sexpr) );
// mword *pay = inline_bpdl_list_list( this_bvm, (mword*)icdr(sexpr) );
return tptr_new(this_bvm, tag, pay);//_bons(this_bvm, leaf_list);
}
mword *inline_bpdl_label_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_label_list#
mword *sexpr_label = (mword*)icar(sexpr);
if(bpdl_is_label_nil(sexpr_label)){
return nil;
}
mword *macro_code_list;
mword *bpdl_list;
mword *result = nil;
mword *bpdl_label = _lf2by(this_bvm, sexpr_label);
mword *bpdl_label_hash = _hash8(this_bvm,bpdl_label);
if(trie_exists(this_bvm, bpdl_macro_table, bpdl_label_hash, nil)){
bpdl_list = inline_bpdl_list_list(this_bvm, (mword *)icdr(sexpr));
macro_code_list =
_cons( this_bvm,
_cp( this_bvm, _ith( this_bvm, trie_lookup_hash(this_bvm, bpdl_macro_table, bpdl_label_hash, nil), 2) ),
nil);
// result = lib_babelc(this_bvm, (mword*)icar(macro_code_list), bpdl_list);
result = lib_babelcs(this_bvm, (mword*)icar(macro_code_list), bpdl_list, this_bvm->soft_root);
}
else{
_fatal("Unrecognized label-list"); //FIXME Throw exception
}
return result;
}
mword *rinline_bpdl_ptr_list(bvm_cache *this_bvm, mword *sexpr){ // rinline_bpdl_ptr_list#
#ifdef BPDL_TRACE
_trace;
#endif
// 1. string
// 2. number
// 3. label (lookup in sym-table)
// 4. recurse inline_bpdl
mword entry_type;
mword *list_head = nil;
mword *list_curr = nil;
mword *new_entry;
mword *bpdl_label;
mword *bpdl_label_hash;
while(!is_nil(sexpr)){
entry_type = get_bpdl_list_entry_type((mword*)icar(sexpr));
switch(entry_type){
case BPDL_LIST_ENTRY_DNUMBER:
case BPDL_LIST_ENTRY_HNUMBER:
case BPDL_LIST_ENTRY_DQUOTE:
case BPDL_LIST_ENTRY_SQUOTE:
new_entry =
_cons( this_bvm,
bpdl_const_to_bstruct(
this_bvm,
(mword*)icar(sexpr),
entry_type),
nil);
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
case BPDL_LIST_ENTRY_LABEL:
bpdl_label = _lf2by(this_bvm, (mword*)icar(sexpr));
bpdl_label_hash = _hash8(this_bvm,bpdl_label);
if(_arcmp((mword*)icar(sexpr), SEXPR_NIL_SYMBOL) == 0){
new_entry =
_cons( this_bvm,
lusym(this_bvm,
_hash8( this_bvm, bpdl_label )),
nil);
}
else{
if(exsym(this_bvm, bpdl_label_hash)){ // XXX PERF (double-lookup)
new_entry =
_cons( this_bvm,
lusym(this_bvm,
bpdl_label_hash),
nil);
}
else{
new_entry =
_cons( this_bvm,
tptr_new(this_bvm, BABEL_TAG_REF_SYM_LOCAL, tptr_new(this_bvm, bpdl_label_hash, nil)),
nil);
}
}
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
case BPDL_LIST_ENTRY_INTE:
new_entry =
_cons( this_bvm,
inline_bpdl(this_bvm, (mword*)icar(sexpr)),
nil);
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
default:
_fatal("Unrecognized bpdl ptr list entry"); //FIXME Throw exception
}
sexpr = (mword*)icdr(sexpr);
}
return list_head;
}
mword *inline_bpdl_code_list(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl_code_list#
#ifdef BPDL_TRACE
_trace;
#endif
// 1. string
// 2. number
// 3. built-in (opcodes)
// 3. label (lookup in sym-table)
// 4. recurse inline_bpdl
mword entry_type;
mword *list_head = nil;
mword *list_curr = nil;
mword *new_entry;
mword *bpdl_label;
mword *bpdl_label_hash;
while(!is_nil(sexpr)){
entry_type = get_bpdl_list_entry_type((mword*)icar(sexpr));
switch(entry_type){
case BPDL_LIST_ENTRY_DNUMBER:
case BPDL_LIST_ENTRY_HNUMBER:
case BPDL_LIST_ENTRY_DQUOTE:
case BPDL_LIST_ENTRY_SQUOTE:
new_entry =
_cons( this_bvm,
_cons( this_bvm,
bpdl_const_to_bstruct(
this_bvm,
(mword*)icar(sexpr),
entry_type),
nil), nil);
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
case BPDL_LIST_ENTRY_LABEL:
if(_arcmp((mword*)icar(sexpr), SEXPR_NIL_SYMBOL) == 0){
new_entry =
_cons( this_bvm,
_cons( this_bvm,
nil,
nil), nil);
}
else{
// if built-in:
// substitute opcode-value
bpdl_label = _lf2by(this_bvm, (mword*)icar(sexpr));
bpdl_label_hash = _hash8(this_bvm,bpdl_label);
if(trie_exists(this_bvm, bpdl_opcode_table, bpdl_label_hash, nil)){
new_entry =
_cons( this_bvm,
_cp( this_bvm, _ith( this_bvm, trie_lookup_hash(this_bvm, bpdl_opcode_table, bpdl_label_hash, nil), 2) ),
nil);
}
else{
new_entry =
_cons( this_bvm,
tptr_new(this_bvm, bpdl_label_hash, nil),
nil);
}
}
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
case BPDL_LIST_ENTRY_INTE:
new_entry =
_cons( this_bvm,
_cons( this_bvm,
inline_bpdl(this_bvm, (mword*)icar(sexpr)),
nil), nil);
if(is_nil(list_head)){
list_head = list_curr = new_entry;
}
else{
_append_direct(this_bvm, list_curr, new_entry);
list_curr = (mword*)icdr(list_curr); // Save unnecessary traversal
}
break;
default:
_d(entry_type);
_fatal("Unrecognized bpdl list entry"); //FIXME Throw exception
}
sexpr = (mword*)icdr(sexpr);
}
return list_head;
}
