/** $apply : function -> any* -> any <doc> Apply the function to several arguments. Return a function asking for more arguments or the function result if more args needed. </doc> **/ static value builtin_apply( value *args, int nargs ) { value f, env; int fargs; int i; nargs--; args++; if( nargs < 0 ) neko_error(); f = args[-1]; if( !val_is_function(f) ) neko_error(); if( nargs == 0 ) return f; fargs = val_fun_nargs(f); if( fargs == nargs || fargs == VAR_ARGS ) return val_callN(f,args,nargs); if( nargs > fargs ) neko_error(); env = alloc_array(fargs + 1); val_array_ptr(env)[0] = f; for(i=0;i<nargs;i++) val_array_ptr(env)[i+1] = args[i]; while( i++ < fargs ) val_array_ptr(env)[i] = val_null; return neko_alloc_apply(fargs-nargs,env); }
/** $closure : function -> object -> any* -> function <doc>Build a closure by applying a given number of arguments to a function</doc> **/ static value builtin_closure( value *args, int nargs ) { value f; value env; int fargs; if( nargs <= 1 ) failure("Invalid closure arguments number"); f = args[0]; if( !val_is_function(f) ) neko_error(); fargs = val_fun_nargs(f); if( fargs != VAR_ARGS && fargs < nargs-2 ) failure("Invalid closure arguments number"); env = alloc_array(nargs); memcpy(val_array_ptr(env),args,nargs * sizeof(f)); f = alloc_function( closure_callback, VAR_ARGS, "closure_callback" ); ((vfunction*)f)->env = env; return f; }
static value closure_callback( value *args, int nargs ) { value env = NEKO_VM()->env; int cargs = val_array_size(env) - 2; value *a = val_array_ptr(env); value f = a[0]; value o = a[1]; int fargs = val_fun_nargs(f); int i; if( fargs != cargs + nargs && fargs != VAR_ARGS ) return val_null; if( nargs == 0 ) a = val_array_ptr(env) + 2; else if( cargs == 0 ) a = args; else { a = (value*)alloc(sizeof(value)*(nargs+cargs)); for(i=0;i<cargs;i++) a[i] = val_array_ptr(env)[i+2]; for(i=0;i<nargs;i++) a[i+cargs] = args[i]; } return val_callEx(o,f,a,nargs+cargs,NULL); }
static void val_buffer_rec( buffer b, value v, vlist *stack ) { char buf[32]; int i, l; vlist *vtmp = stack; while( vtmp != NULL ) { if( vtmp->v == v ) { buffer_append_sub(b,"...",3); return; } vtmp = vtmp->next; } switch( val_type(v) ) { case VAL_INT: buffer_append_sub(b,buf,sprintf(buf,"%d",val_int(v))); break; case VAL_STRING: buffer_append_sub(b,val_string(v),val_strlen(v)); break; case VAL_FLOAT: buffer_append_sub(b,buf,sprintf(buf,FLOAT_FMT,val_float(v))); break; case VAL_NULL: buffer_append_sub(b,"null",4); break; case VAL_BOOL: if( val_bool(v) ) buffer_append_sub(b,"true",4); else buffer_append_sub(b,"false",5); break; case VAL_FUNCTION: buffer_append_sub(b,buf,sprintf(buf,"#function:%d",val_fun_nargs(v))); break; case VAL_OBJECT: { value s = val_field(v,id_string); if( s != val_null ) s = val_callEx(v,s,NULL,0,NULL); if( val_is_string(s) ) buffer_append_sub(b,val_string(s),val_strlen(s)); else { vlist2 vtmp; vtmp.v = v; vtmp.next = stack; vtmp.b = b; vtmp.prev = 0; buffer_append_sub(b,"{",1); val_iter_fields(v,val_buffer_fields,&vtmp); if( vtmp.prev ) buffer_append_sub(b," }",2); else buffer_append_sub(b,"}",1); } break; } case VAL_ARRAY: buffer_append_sub(b,"[",1); l = val_array_size(v); { vlist vtmp; vtmp.v = v; vtmp.next = stack; for(i=0;i<l;i++) { value vi = val_array_ptr(v)[i]; val_buffer_rec(b,vi,&vtmp); if( i != l - 1 ) buffer_append_sub(b,",",1); } } buffer_append_sub(b,"]",1); break; case VAL_INT32: buffer_append_sub(b,buf,sprintf(buf,"%d",val_int32(v))); break; case VAL_ABSTRACT: buffer_append_sub(b,"#abstract",9); break; default: buffer_append_sub(b,"#unknown",8); break; } }
/** $nargs : function -> int <doc> Return the number of arguments of a function. If the function have a variable number of arguments, it returns -1 </doc> **/ static value builtin_nargs( value f ) { val_check(f,function); return alloc_int( val_fun_nargs(f) ); }
static value unserialize_rec( sbuffer *b, value loader ) { switch( read_char(b) ) { case 'N': return val_null; case 'T': return val_true; case 'F': return val_false; case 'i': return alloc_int(read_int(b)); case 'I': return alloc_int32(read_int(b)); case 'f': { tfloat d; read_str(b,sizeof(tfloat),&d); return alloc_float(d); } case 's': { int l = read_int(b); value v; if( l < 0 || l > max_string_size ) ERROR(); v = alloc_empty_string(l); add_ref(b,v); read_str(b,l,(char*)val_string(v)); return v; } case 'o': { int f; value o = alloc_object(NULL); add_ref(b,o); while( (f = read_int(b)) != 0 ) { value fval = unserialize_rec(b,loader); alloc_field(o,(field)f,fval); } switch( read_char(b) ) { case 'p': { value v = unserialize_rec(b,loader); if( !val_is_object(v) ) ERROR(); ((vobject*)o)->proto = (vobject*)v; } break; case 'z': break; default: ERROR(); } return o; } case 'r': { int n = read_int(b); if( n < 0 || n >= b->nrefs ) ERROR(); return b->trefs[b->nrefs - n - 1]; } case 'a': { int i; int n = read_int(b); value o; value *t; if( n < 0 || n > max_array_size ) ERROR(); o = alloc_array(n); t = val_array_ptr(o); add_ref(b,o); for(i=0;i<n;i++) t[i] = unserialize_rec(b,loader); return o; } case 'p': { int nargs = read_int(b); vfunction *f = (vfunction*)alloc_function((void*)1,nargs,NULL); vfunction *f2; value name; add_ref(b,(value)f); name = unserialize_rec(b,loader); f2 = (vfunction*)val_ocall2(loader,id_loadprim,name,alloc_int(nargs)); if( !val_is_function(f2) || val_fun_nargs(f2) != nargs ) failure("Loader returned not-a-function"); f->t = f2->t; f->addr = f2->addr; f->module = f2->module; return (value)f; } case 'L': { vfunction *f = (vfunction*)alloc_function((void*)1,0,NULL); value mname; int pos; int nargs; value env; add_ref(b,(value)f); mname = unserialize_rec(b,loader); pos = read_int(b); nargs = read_int(b); env = unserialize_rec(b,loader); if( !val_is_array(env) ) ERROR(); { value exp = val_ocall2(loader,id_loadmodule,mname,loader); value mval; unsigned int i; int_val *mpos; neko_module *m; if( !val_is_object(exp) ) { buffer b = alloc_buffer("module "); val_buffer(b,mname); buffer_append(b," is not an object"); bfailure(b); } mval = val_field(exp,id_module); if( !val_is_kind(mval,neko_kind_module) ) { buffer b = alloc_buffer("module "); val_buffer(b,mname); buffer_append(b," has invalid type"); bfailure(b); } m = (neko_module*)val_data(mval); mpos = m->code + pos; for(i=0;i<m->nglobals;i++) { vfunction *g = (vfunction*)m->globals[i]; if( val_is_function(g) && g->addr == mpos && g->module == m && g->nargs == nargs ) { f->t = VAL_FUNCTION; f->env = env; f->addr = mpos; f->nargs = nargs; f->module = m; return (value)f; } } { buffer b = alloc_buffer("module "); val_buffer(b,mname); buffer_append(b," has been modified"); bfailure(b); } } return val_null; } case 'x': { value mname = unserialize_rec(b,loader); value data = unserialize_rec(b,loader); value exports = val_ocall2(loader,id_loadmodule,mname,loader); value s; if( !val_is_object(exports) ) { buffer b = alloc_buffer("module "); val_buffer(b,mname); buffer_append(b," is not an object"); bfailure(b); } s = val_field(exports,id_unserialize); if( !val_is_function(s) || (val_fun_nargs(s) != 1 && val_fun_nargs(s) != VAR_ARGS) ) { buffer b = alloc_buffer("module "); val_buffer(b,mname); buffer_append(b," has invalid __unserialize function"); } s = val_call1(s,data); add_ref(b,s); return s; } case 'h': { int i; vhash *h = (vhash*)alloc(sizeof(vhash)); h->ncells = read_int(b); h->nitems = read_int(b); h->cells = (hcell**)alloc(sizeof(hcell*)*h->ncells); for(i=0;i<h->ncells;i++) h->cells[i] = NULL; for(i=0;i<h->nitems;i++) { hcell **p; hcell *c = (hcell*)alloc(sizeof(hcell)); c->hkey = read_int(b); c->key = unserialize_rec(b,loader); c->val = unserialize_rec(b,loader); c->next = NULL; p = &h->cells[c->hkey % h->ncells]; while( *p != NULL ) p = &(*p)->next; *p = c; } return alloc_abstract(k_hash,h); } default: ERROR(); return val_null; } }
void serialize_rec( sbuffer *b, value o ) { b->nrec++; if( b->nrec > 350 ) failure("Serialization stack overflow"); switch( val_type(o) ) { case VAL_NULL: write_char(b,'N'); break; case VAL_BOOL: if( val_bool(o) ) write_char(b,'T'); else write_char(b,'F'); break; case VAL_INT: write_char(b,'i'); write_int(b,val_int(o)); break; case VAL_FLOAT: write_char(b,'f'); write_str(b,sizeof(tfloat),&val_float(o)); break; case VAL_STRING: if( !write_ref(b,o,NULL) ) { write_char(b,'s'); write_int(b,val_strlen(o)); write_str(b,val_strlen(o),val_string(o)); } break; case VAL_OBJECT: { value s; if( !write_ref(b,o,&s) ) { if( s != NULL ) { // reference was not written if( !val_is_function(s) || (val_fun_nargs(s) != 0 && val_fun_nargs(s) != VAR_ARGS) ) failure("Invalid __serialize method"); write_char(b,'x'); serialize_rec(b,((neko_module*)((vfunction*)s)->module)->name); serialize_rec(b,val_ocall0(o,id_serialize)); // put reference back write_ref(b,o,NULL); break; } write_char(b,'o'); val_iter_fields(o,serialize_fields_rec,b); write_int(b,0); o = (value)((vobject*)o)->proto; if( o == NULL ) write_char(b,'z'); else { write_char(b,'p'); serialize_rec(b,o); } } } break; case VAL_ARRAY: if( !write_ref(b,o,NULL) ) { int i; int n = val_array_size(o); write_char(b,'a'); write_int(b,n); for(i=0;i<n;i++) serialize_rec(b,val_array_ptr(o)[i]); } break; case VAL_FUNCTION: if( !write_ref(b,o,NULL) ) { neko_module *m; if( val_tag(o) == VAL_PRIMITIVE ) { // assume that alloc_array(0) return a constant array ptr // we don't want to access custom memory (maybe not a ptr) if( ((vfunction*)o)->env != alloc_array(0) ) failure("Cannot Serialize Primitive with environment"); write_char(b,'p'); write_int(b,((vfunction*)o)->nargs); serialize_rec(b,((vfunction*)o)->module); break; } if( val_tag(o) == VAL_JITFUN ) failure("Cannot Serialize JIT method"); write_char(b,'L'); m = (neko_module*)((vfunction*)o)->module; serialize_rec(b,m->name); write_int(b,(int)((int_val*)((vfunction*)o)->addr - m->code)); write_int(b,((vfunction*)o)->nargs); serialize_rec(b,((vfunction*)o)->env); } break; case VAL_INT32: write_char(b,'I'); write_int(b,val_int32(o)); break; case VAL_ABSTRACT: if( val_is_kind(o,k_hash) ) { int i; vhash *h = val_hdata(o); write_char(b,'h'); write_int(b,h->ncells); write_int(b,h->nitems); for(i=0;i<h->ncells;i++) { hcell *c = h->cells[i]; while( c != NULL ) { write_int(b,c->hkey); serialize_rec(b,c->key); serialize_rec(b,c->val); c = c->next; } } break; } default: failure("Cannot Serialize Abstract"); break; } b->nrec--; }
int api_val_fun_nargs(value arg1) { return val_fun_nargs(arg1); }