mword is_false_tptr(mword *bs){ // is_false_tptr#
return
(tageq(bs, BABEL_TAG_FALSE , TAG_SIZE)
|| tageq(bs, BABEL_TAG_REJECT , TAG_SIZE)
|| tageq(bs, BABEL_TAG_UNEXIST , TAG_SIZE)
|| tageq(bs, BABEL_TAG_INTERP_NIL, TAG_SIZE));
}
// 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);
}
// XXX The return-value from this function contains unsafe pointers!!! XXX
// XXX internal interp use ONLY XXX
// XXX If you pass tag=nil, returns ALL tags in bs XXX
// XXX PERF: A _tags2ar (like _bs2ar) would be more efficient XXX
//
mword *tptr_find_tag_unsafe(bvm_cache *this_bvm, mword *bs, mword *tag){ // tptr_find_tag_unsafe#
mword *span_array = _bs2ar(this_bvm, bs);
mword size_span_array = size(span_array);
mword size_inte;
mword *tag_list = nil;
mword *curr_span_elem;
mword *curr_inte_elem;
//_dump(span_array);
int i,j;
for(i=0; i<size_span_array; i++){
curr_span_elem = rci(span_array,i);
if(is_inte(curr_span_elem)){ // check each element
size_inte = size(curr_span_elem);
for(j=0;j<size_inte;j++){
curr_inte_elem = rci(curr_span_elem,j);
if(is_nil(curr_inte_elem)){
continue;
}
if(is_tptr(curr_inte_elem)){
if(is_nil(tag)){
// push onto tag_list
if(is_nil(tag_list)){
tag_list = _cons(this_bvm, (curr_span_elem+j), nil);
}
else{
_unshift(this_bvm, tag_list, (curr_span_elem+j));
}
}
else{
if( tageq(curr_inte_elem, tag, TAG_SIZE) ){
// push onto tag_list
if(is_nil(tag_list)){
tag_list = _cons(this_bvm, (curr_span_elem+j), nil);
}
else{
_unshift(this_bvm, tag_list, (curr_span_elem+j));
}
}
}
}
}
}
}
return tag_list;
}
