int closure_execlpiv(closure_t *closure, pointer cell, void *ptr, int id,
const char *fmt, va_list args)
{
pointer head, tmp, result;
scheme *sc = closure->sc;
/* Convert the C args to Scheme. */
if (fmt) {
head = vpack(sc, fmt, args);
} else {
head = sc->NIL;
}
/* Protect the list while allocating cells. */
tmp = head;
if (tmp != sc->NIL) {
sc->vptr->protect(sc, tmp);
}
/* Prepend the cell, ptr and id to the arg list. */
head = _cons(sc, scm_mk_integer(sc, id), head, 0);
head = _cons(sc, scm_mk_ptr(sc, ptr), head, 0);
head = _cons(sc, cell, head, 0);
/* Unprotect the list now that we're done allocating. */
if (tmp != sc->NIL) {
sc->vptr->unprotect(sc, tmp);
}
/* Evaluate the closure. */
result = closure_exec_with_scheme_args(closure, head);
/* Translate the result to an int. */
return closure_translate_result(closure->sc, result);
}
/* to speed up some things */
static pointer s_fast_foreach(scheme *sc, pointer args) {
if(args == sc->NIL)
return sc->F;
pointer proc, lst, item;
proc = sc->vptr->pair_car(args);
if(proc == sc->NIL || !sc->vptr->is_closure(proc))
return sc->F;
args = sc->vptr->pair_cdr(args);
lst = sc->vptr->pair_car(args);
if(lst == sc->NIL || !sc->vptr->is_pair(lst))
return sc->F;
while(1) {
item = sc->vptr->pair_car(lst);
if(item == sc->NIL)
break;
/* apply function */
scheme_call(sc, proc, _cons(sc, item, sc->NIL, 0));
lst = sc->vptr->pair_cdr(lst);
}
return sc->T;
}
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;
}
static muse_cell json_read_object_expr( muse_port_t p )
{
muse_env *env = p->env;
muse_debug_only(muse_char c =) port_getchar(p);
assert( c == '{' );
json_skip_whitespace(p);
{
muse_cell h = _cons( MUSE_NIL, MUSE_NIL );
int sp = _spos();
muse_cell t = _cons( _mk_nativefn(fn_list,NULL), MUSE_NIL );
_setht( h, _mk_nativefn(fn_alist_to_hashtable,NULL), _cons( t, MUSE_NIL ) );
_unwind(sp);
return json_share_object_expr( env, json_read_object_expr_items( env, p, h, t, sp ) );
}
}
static muse_cell json_read_array_items( muse_env *env, muse_port_t p, muse_cell h, muse_cell t, int N )
{
int i;
if ( port_eof(p) ) {
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-array"), MUSE_NIL );
} else {
muse_char c = port_getchar(p);
if ( c == ']' ) {
muse_cell v = muse_mk_vector( env, N );
for ( i = 0; i < N; ++i ) {
muse_vector_put( env, v, i, _next(&h) );
}
return v;
} else {
port_ungetchar( c, p );
}
}
if ( h ) {
int sp = _spos();
muse_cell n = _cons( json_read(p), MUSE_NIL );
_sett( t, n );
t = n;
_unwind(sp);
} else {
h = t = _cons( json_read(p), MUSE_NIL );
}
json_skip_whitespace(p);
if ( port_eof(p) ) {
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-array"), h );
} else {
muse_char c = port_getchar(p);
if ( c == ',' ) {
return json_read_array_items( env, p, h, t, N+1 );
} else if ( c == ']' ) {
port_ungetc( c, p );
return json_read_array_items( env, p, h, t, N+1 );
} else {
return muse_raise_error( env, _csymbol(L"json:array-syntax-error"), h );
}
}
}
Cons* cons(void* car, void* cdr) {
Cons* c;
if(cdr) {
if(type(cdr) == CONS) {
c = (Cons*)cdr;
if(c->car && !c->cdr) {
c->cdr = c->car;
c->car = car;
return c;
} else if (c->car && c->cdr){
return _cons(car, c);
} else {
c->car = car;
return c;
}
}
}
return _cons(car, cdr);
}
static muse_cell json_read_array_expr( muse_port_t p )
{
muse_env *env = p->env;
muse_debug_only(muse_char c =) port_getchar(p);
assert( c == '[' );
json_skip_whitespace(p);
return json_share_array_expr(
env,
_cons(
_mk_nativefn(fn_vector_from_args,NULL),
json_read_array_expr_items( env, p, MUSE_NIL, MUSE_NIL, 0 ) ) );
}
int closure_execvl(closure_t *closure, const char *fmt, va_list args, pointer cell)
{
pointer head, result;
scheme *sc = closure->sc;
/* Convert the C args to Scheme. */
if (fmt) {
head = vpack(sc, fmt, args);
} else {
head = sc->NIL;
}
/* Append args to the list */
if (head == sc->NIL) {
/* args is the only thing on the list */
head = _cons(sc, cell, sc->NIL, 0);
} else {
/* Protect the list while allocating for _cons */
sc->vptr->protect(sc, head);
/* Find the end of the list */
pointer tail = head;
while (scm_cdr(sc, tail) != sc->NIL) {
tail = scm_cdr(sc, tail);
}
/* Append the args to the tail of the list */
tail->_object._cons._cdr = _cons(sc, cell, sc->NIL, 0);
/* Unprotect the list now that we're done allocating. */
sc->vptr->unprotect(sc, head);
}
/* Evaluate the closure. */
result = closure_exec_with_scheme_args(closure, head);
/* Translate the result to an int. */
return closure_translate_result(closure->sc, result);
}
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);
}
static muse_cell json_read_array_expr_items( muse_env *env, muse_port_t p, muse_cell h, muse_cell t, int N )
{
if ( port_eof(p) ) {
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-array"), MUSE_NIL );
} else {
muse_char c = port_getchar(p);
if ( c == ']' ) {
return h;
} else {
port_ungetchar( c, p );
}
}
if ( h ) {
int sp = _spos();
muse_cell n = _cons( json_read_expr(p), MUSE_NIL );
_sett( t, n );
t = n;
_unwind(sp);
} else {
h = t = _cons( json_read_expr(p), MUSE_NIL );
}
json_skip_whitespace(p);
if ( port_eof(p) ) {
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-array"), h );
} else {
muse_char c = port_getchar(p);
if ( c == ',' ) {
return json_read_array_expr_items( env, p, h, t, N+1 );
} else if ( c == ']' ) {
port_ungetchar( c, p );
return json_read_array_expr_items( env, p, h, t, N+1 );
} else {
return muse_raise_error( env, _csymbol(L"json:array-syntax-error"), h );
}
}
}
static void json_write_hash( muse_port_t p, muse_cell obj )
{
muse_env *env = p->env;
int sp = _spos();
muse_cell alist = fn_hashtable_to_alist( env, NULL, _cons(obj,MUSE_NIL) );
_unwind(sp);
port_putc( '{', p );
while ( alist ) {
muse_cell ht = _next(&alist);
json_write_string(p, _symname(_head(ht)));
port_putc(':',p);
json_write(p,_tail(ht));
if ( alist )
port_putc( ',', p );
}
port_putc( '}', p );
}
static muse_cell json_read_object_expr_items( muse_env *env, muse_port_t p, muse_cell h, muse_cell t, int sp )
{
json_skip_whitespace(p);
if ( port_eof(p) )
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-object"), MUSE_NIL );
else {
muse_char c = port_getchar(p);
if ( c == '}' ) {
return h;
} else {
muse_cell key, value;
port_ungetchar(c,p);
key = json_read_key(p);
json_skip_whitespace(p);
if ( port_eof(p) ) {
return muse_raise_error( env, _csymbol(L"json:end-of-file-in-object"), MUSE_NIL );
} else {
muse_char c = port_getchar(p);
if ( c == ':' ) {
muse_cell assoc;
value = json_read_expr(p);
if ( json_is_constant(env, value) ) {
assoc = _cons( muse_quote( env, _cons( key, value ) ), MUSE_NIL );
} else {
assoc = _cons( _cons( _mk_nativefn(fn_cons,NULL), _cons( muse_quote(env,key), _cons( value, MUSE_NIL ) ) ), MUSE_NIL );
}
_sett( t, assoc );
t = assoc;
_unwind(sp);
json_skip_whitespace(p);
{
muse_char c = port_getchar(p);
if ( c == ',' ) {
return json_read_object_expr_items( env, p, h, t, sp );
} else if ( c == '}' ) {
return h;
} else {
return muse_raise_error( env, _csymbol(L"json:object-syntax-error"), h );
}
}
} else {
return muse_raise_error( env, _csymbol(L"json:object-syntax-error"), h );
}
}
}
}
}
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;
}
// 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;
}
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;
}