/* 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; }
inline mword *get_from_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index){ // get_from_udr_stack# // return _chain_deref( this_bvm->sym_table, (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )) ); // return (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )); return _chain_deref( this_bvm, (mword*)icar( _ith( (mword*)icar( stack_ptr ), stack_index )) ); }
/* stack operator **clear** > Empties the stack */ bvm_cache *clear(bvm_cache *this_bvm){ // clear# (mword*)icar(this_bvm->dstack_ptr) = nil; (mword*)icar(this_bvm->ustack_ptr) = nil; return this_bvm; }
inline mword *set_in_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index, mword *bs){ // set_in_udr_stack# // mword *stack_entry = _chain_deref( this_bvm->sym_table, (mword*)icar( icar( _ith( stack_ptr, stack_index ))) ); mword *stack_entry = (mword*)icar( icar( _ith( stack_ptr, stack_index ))); (mword*)c(stack_entry,0) = bs; return stack_entry; }
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 *pop_udr_stack(mword *stack_ptr){ // pop_udr_stack# //mword *temp = (mword*)icar(icar(stack_ptr)); mword *temp = (mword*)icar(stack_ptr); (mword*)*stack_ptr = _pop((mword*)icar(stack_ptr)); free_lumbar(temp); return (mword*)icar(temp); //return temp; }
/* stack operator **take** > Takes TOS items from the stack and puts them into a list. > If TOS == -1, the entire stack is taken. */ bvm_cache *take(bvm_cache *this_bvm){ // take# int count = (int)icar(dstack_get(this_bvm,0)); popd(this_bvm); mword *result = nil; mword *list_entry; mword *temp; int i; if(count == -1){ // while(!is_nil(this_bvm->dstack_ptr)){ while(!dstack_empty(this_bvm)){ list_entry = dstack_get(this_bvm,0); result = consa2(this_bvm, list_entry, result); popd(this_bvm); } } else{ for(i=0;i<count;i++){ list_entry = dstack_get(this_bvm,0); result = consa2(this_bvm, list_entry, result); popd(this_bvm); } } pushd(this_bvm, result, IMMORTAL); 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) ) ); }
inline mword *zap_from_udr_stack(bvm_cache *this_bvm, mword *stack_ptr, mword stack_index){ // zap_from_udr_stack# mword *temp; mword *zapped; mword *tail; mword length; mword *work_stack = (mword*)car(stack_ptr); if(stack_index==0){ pop_udr_stack(stack_ptr); //work_stack = pop_udr_stack(stack_ptr); //temp = pop_udr_stack(work_stack); //(mword*)c(temp,0) = nil; //_del(temp); } else{ length = _len(work_stack); if( length > stack_index+1 ){ zapped = _list_cut(work_stack, stack_index); tail = _list_cut(zapped, 1); (mword*)c(icar(zapped),0) = nil; //_dump(zapped); //die; //_del(zapped); _append_direct(this_bvm, work_stack,tail); } else if( length > stack_index ){ zapped = _list_cut(work_stack, stack_index); (mword*)c(zapped,0) = nil; //_del(zapped); } // else do nothing } (mword*)icar(stack_ptr) = work_stack; // _dump(stack_ptr); // die; return stack_ptr; }
/* stack operator **depth** > Places the depth of the stack on TOS. To gather up the entire stack > into a list: > > depth take */ bvm_cache *depth(bvm_cache *this_bvm){ // depth# mword *result = _new2va( this_bvm, 1); *result = _len((mword*)icar(this_bvm->dstack_ptr)); pushd(this_bvm, result, IMMORTAL); 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); }
/* stack operator **sel** (?) > Selects one of the top two values on the stack: > `{f} {X} {Y}| -> {X}|` > `{t} {X} {Y}| -> {Y}|` > `{f} [X] {Y}| -> [X]|` > `{t} [X] {Y}| -> {Y}|` > etc. > > Where f = 0 and t != 0 */ bvm_cache *sel(bvm_cache *this_bvm){ // sel# mword *temp = pop_udr_stack(this_bvm->dstack_ptr); if(!is_false(icar(temp))){ popd(this_bvm); } else{ remove_from_udr_stack(this_bvm, this_bvm->dstack_ptr, 1); } return this_bvm; }
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; }
/* 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; }
// 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 *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; }
mword get_bpdl_list_type(mword *sexpr){ // get_bpdl_list_type# #ifdef BPDL_TRACE _trace; #endif if(!is_inte(sexpr) || !is_leaf(icar(sexpr))){ #ifdef BPDL_TRACE _trace; #endif return BPDL_UNKNOWN_LIST; } #ifdef BPDL_TRACE _trace; #endif sexpr = (mword*)icar(sexpr); #ifdef BPDL_TRACE _trace; #endif if( _arcmp(sexpr, SEXPR_LIST_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_LIST_LIST; } else if(_arcmp(sexpr, SEXPR_SEXPR_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_SEXPR_LIST; } else if(_arcmp(sexpr, SEXPR_CODE_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_CODE_LIST; } // else if( bpdl_is_const_like(sexpr) ){ else if( bpdl_is_number(sexpr) ){ #ifdef BPDL_TRACE _trace; #endif return BPDL_SHORT_VAL_LIST; } else if( _arcmp(sexpr, SEXPR_VAL_SYMBOL) == 0 ){ #ifdef BPDL_TRACE _trace; #endif return BPDL_VAL_LIST; } else if( bpdl_is_string(sexpr) ){ #ifdef BPDL_TRACE _trace; #endif return BPDL_SHORT_PTR_LIST; } else if(_arcmp(sexpr, SEXPR_PTR_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_PTR_LIST; } else if(_arcmp(sexpr, SEXPR_HASH_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_HASH_LIST; } else if(_arcmp(sexpr, SEXPR_TAG_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_TAG_LIST; } else if(_arcmp(sexpr, SEXPR_REF_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_REF_LIST; } else if(_arcmp(sexpr, SEXPR_SYM_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_SYM_LIST; } else if(_arcmp(sexpr, SEXPR_BS_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_BS_LIST; } else if(_arcmp(sexpr, SEXPR_QW_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_QW_LIST; } else if(_arcmp(sexpr, SEXPR_TPTR_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_TPTR_LIST; } else if(_arcmp(sexpr, SEXPR_BYTES_SYMBOL) == 0){ #ifdef BPDL_TRACE _trace; #endif return BPDL_BYTES_LIST; } else if( !bpdl_is_const_like(sexpr) ){ #ifdef BPDL_TRACE _trace; #endif return BPDL_LABEL_LIST; } #ifdef BPDL_TRACE _trace; #endif return BPDL_UNKNOWN_LIST; }