/* 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 )); }