/* 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 *tptr_find_tag(bvm_cache *this_bvm, mword *search_bs, mword *tag){ // tptr_find_tag#
if(is_nil(search_bs) || is_nil(tag)){
return nil;
}
mword *search_tag;
if(is_tptr(tag)){
search_tag = tag;
}
else{
search_tag = tptr_new(this_bvm, tag, nil);
}
mword *sub_list = bstruct_find(this_bvm, search_bs, search_tag);
mword *result = nil;
while(!is_nil(sub_list)){
result = _cons(this_bvm, rci(rci(sub_list,0),0), result);
sub_list = (mword*)icdr(sub_list);
}
return result;
}
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)) ));
}
/* stack operator
**swap** (<->)
> Named after the Joy operator
> Swaps the top two items on the stack.
> `{X} {Y}| -> {Y} {X}|`
> `[X] {Y}| -> {Y} [X]|`
> etc.
*/
bvm_cache *swap(bvm_cache *this_bvm){ // swap#
// stack_ptr -> A -> B -> C
//
// stack_ptr -> B
// B -> A
// A -> C
//FIXME: Depth-check the stack
mword *A = (mword*)icar(this_bvm->dstack_ptr);
mword *B = (mword*)icdr(A);
mword *C = (mword*)icdr(B);
(mword*)c(this_bvm->dstack_ptr,0) = B;
(mword*)icdr(B) = A;
(mword*)icdr(A) = C;
return this_bvm;
}
// 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);
}
// same as pop_udr_stack except calls mc_free if PACMAN tag
//
void zap_udr_stack(mword *stack_ptr){ // zap_udr_stack#
mword *free_ptr = (mword*)icar(stack_ptr);
mword *tag = (mword*)icar(icdr(icar(icar(stack_ptr))));
mword *temp = (mword*)icar(icar(icar(stack_ptr)));
(mword*)*stack_ptr = _pop((mword*)icar(stack_ptr));
//_dump(stack_ptr);
// trace;
// _mem(temp);
// printf("\n");
if(is_tptr(tag) && tageq(tag,BABEL_TAG_PACMAN,TAG_SIZE)){
//printf("MATCH\n");
mc_free(temp);
}
free_lumbar(free_ptr);
}
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 *rinline_bpdl_val_list(bvm_cache *this_bvm, mword *sexpr){ // rinline_bpdl_val_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;
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:
new_entry =
_cons( this_bvm,
lusym2(this_bvm,
_lf2by(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;
case BPDL_LIST_ENTRY_INTE:
_fatal("Can't nest inside val/leaf array");
break;
default:
_fatal("Unrecognized bpdl val 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;
}
// Differs from _bpdl because no named-sections and assumes all symbols
// pre-exist in symbol-table
//
mword *inline_bpdl(bvm_cache *this_bvm, mword *sexpr){ // inline_bpdl#
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_trace;
#endif
if(is_nil(sexpr)){
return nil;
}
mword bpdl_list_type = get_bpdl_list_type(sexpr);
switch(bpdl_list_type){
case BPDL_LIST_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_LIST_LIST");
#endif
return inline_bpdl_list_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_CODE_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_CODE_LIST");
#endif
return inline_bpdl_code_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_SHORT_VAL_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_SHORT_VAL_LIST");
#endif
return inline_bpdl_val_list(this_bvm, sexpr);
case BPDL_VAL_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_VAL_LIST");
#endif
return inline_bpdl_val_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_SHORT_PTR_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_SHORT_PTR_LIST");
#endif
return inline_bpdl_ptr_list(this_bvm, sexpr);
case BPDL_PTR_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_PTR_LIST");
#endif
return inline_bpdl_ptr_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_TAG_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_TAG_LIST");
#endif
return inline_bpdl_tag_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_HASH_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_HASH_LIST");
#endif
return inline_bpdl_hash_list(this_bvm, (mword*)icdr(sexpr));
case BPDL_SYM_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_SYM_LIST");
#endif
//inline_bpdl_sym_list(this_bvm, (mword*)icdr(sexpr));
return nil;
case BPDL_BS_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_BS_LIST");
#endif
return nil; // XXX UNIMPLEMENTED
case BPDL_QW_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_QW_LIST");
#endif
return nil; // XXX UNIMPLEMENTED
case BPDL_SEXPR_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_SEXPR_LIST");
#endif
return (mword*)icar((mword*)icdr(sexpr));
case BPDL_LABEL_LIST:
#if(defined BPDL_TRACE || defined INLINE_BPDL_TRACE)
_msg("BPDL_LABEL_LIST");
#endif
// XXX macros go here ... XXX
// return bpdl_lookup_label(this_bvm, (mword*)icar(sexpr));
return inline_bpdl_label_list(this_bvm, sexpr);
default: // BPDL_UNKNOWN_LIST
_msg("Unrecognized list type");
_dump(sexpr);
_die;
}
return nil;
}
void free_lumbar(mword *stack_entry){
mc_free((mword*)icdr(stack_entry));
mc_free(stack_entry);
}
mword *get_tag_from_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index){ // get_tag_from_udr_stack#
// return _chain_deref( this_bvm->sym_table, (mword*)icdr( _ith( (mword*)icar( stack_ptr ), stack_index )) );
return (mword*)icdr( _ith( (mword*)icar( stack_ptr ), stack_index ));
}
