예제 #1
0
파일: closure.c 프로젝트: Elzair/nazghul
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);
}
예제 #2
0
파일: sys.cpp 프로젝트: edeproject/svn
/* 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;
}
예제 #3
0
파일: tptr.c 프로젝트: claytonkb/Babel
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;

}
예제 #4
0
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 ) );
	}
}
예제 #5
0
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 );
		}
	}
}
예제 #6
0
파일: types.c 프로젝트: jondistad/uberlisp
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);
}
예제 #7
0
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 ) ) );
}
예제 #8
0
파일: closure.c 프로젝트: Elzair/nazghul
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);
}
예제 #9
0
파일: bpdl.c 프로젝트: claytonkb/Babel
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);

}
예제 #10
0
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 );
		}
	}
}
예제 #11
0
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 );
}
예제 #12
0
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 );
				}
			}
		}
	}
}
예제 #13
0
파일: bpdl.c 프로젝트: claytonkb/Babel
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;

}
예제 #14
0
파일: tptr.c 프로젝트: claytonkb/Babel
// 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;

}
예제 #15
0
파일: bpdl.c 프로젝트: claytonkb/Babel
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;

}
예제 #16
0
파일: bpdl.c 프로젝트: claytonkb/Babel
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;

}
예제 #17
0
파일: bpdl.c 프로젝트: claytonkb/Babel
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;

}