Logo Search packages:      
Sourcecode: neko version File versions  Download package

builtins.c

/* ************************************************************************ */
/*                                                                                                                */
/*  Neko Virtual Machine                                                                              */
/*  Copyright (c)2005 Motion-Twin                                                               */
/*                                                                                                                */
/* This library is free software; you can redistribute it and/or              */
/* modify it under the terms of the GNU Lesser General Public                       */
/* License as published by the Free Software Foundation; either                     */
/* version 2.1 of the License, or (at your option) any later version.         */
/*                                                                                                                */
/* This library is distributed in the hope that it will be useful,                  */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of             */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          */
/* Lesser General Public License or the LICENSE file for more details.        */
/*                                                                                                                */
/* ************************************************************************ */
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include "neko.h"
#include "objtable.h"
#include "vm.h"

#ifdef NEKO_MINGW
#     undef setjmp
#     define setjmp _setjmp
#endif

#ifdef NEKO_VCC
      long _ftol( double f );
      long _ftol2( double f) { return _ftol(f); };
#endif

extern value *neko_builtins;

/**
      <doc>
            <h1>Builtins</h1>
            <p>
                  Builtins are basic operations that can be optimized by the Neko compiler.
            </p>
      </doc>
**/

/**   <doc><h2>Array Builtins</h2></doc> **/

/**
      $array : any* -> array
      <doc>Create an array from a list of values</doc>
**/
static value builtin_array( value *args, int nargs ) {
      value a = alloc_array(nargs);
      int i;
      for(i=0;i<nargs;i++)
            val_array_ptr(a)[i] = args[i];
      return a;
}

/**
      $amake : n:int -> array
      <doc>Create an array of size [n]</doc>
**/
static value builtin_amake( value size ) {
      value a;
      int i,s;
      val_check(size,int);
      s = val_int(size);
      a = alloc_array(s);
      for(i=0;i<s;i++)
            val_array_ptr(a)[i] = val_null;
      return a;
}

/**
      $acopy : array -> array
      <doc>Make a copy of an array</doc>
**/
static value builtin_acopy( value a ) {
      int i;
      value a2;
      val_check(a,array);
      a2 = alloc_array(val_array_size(a));
      for(i=0;i<val_array_size(a);i++)
            val_array_ptr(a2)[i] = val_array_ptr(a)[i];
      return a2;
}

/**
      $asize : array -> int
      <doc>Return the size of an array</doc>
**/
static value builtin_asize( value a ) {
      val_check(a,array);
      return alloc_int( val_array_size(a) );
}

/**
      $asub : array -> p:int -> l:int -> array
      <doc>
      Return [l] elements starting at position [p] of an array.
      An error occurs if out of array bounds.
      </doc>
**/
static value builtin_asub( value a, value p, value l ) {
      value a2;
      int i;
      int pp, ll;
      val_check(a,array);
      val_check(p,int);
      val_check(l,int);
      pp = val_int(p);
      ll = val_int(l);
      if( pp < 0 || ll < 0 || pp+ll < 0 || pp+ll > val_array_size(a) )
            neko_error();
      a2 = alloc_array(ll);
      for(i=0;i<ll;i++)
            val_array_ptr(a2)[i] = val_array_ptr(a)[pp+i];
      return a2;
}

/**
      $ablit : dst:array -> dst_pos:int -> src:array -> src_pos:int -> len:int -> array
      <doc>
      Copy [len] elements from [src_pos] of [src] to [dst_pos] of [dst].
      An error occurs if out of arrays bounds.
      </doc>
**/
static value builtin_ablit( value dst, value dp, value src, value sp, value l ) {
      int dpp, spp, ll;
      val_check(dst,array);
      val_check(dp,int);
      val_check(src,array);
      val_check(sp,int);
      val_check(l,int);
      dpp = val_int(dp);
      spp = val_int(sp);
      ll = val_int(l);
      if( dpp < 0 || spp < 0 || ll < 0 || dpp + ll < 0 || spp + ll  < 0 || dpp + ll > val_array_size(dst) || spp + ll > val_array_size(src) )
            neko_error();
      memmove(val_array_ptr(dst)+dpp,val_array_ptr(src)+spp,ll * sizeof(value));
      return val_true;
}

/**
      $aconcat : array array -> array
      <doc>
      Build a single array from several ones.
      </doc>
**/
static value builtin_aconcat( value arrs ) {
      int tot = 0;
      int len;
      int i;
      value all;
      val_check(arrs,array);
      len = val_array_size(arrs);
      for(i=0;i<len;i++) {
            value a = val_array_ptr(arrs)[i];
            val_check(a,array);
            tot += val_array_size(a);
      }
      all = alloc_array(tot);
      tot = 0;
      for(i=0;i<len;i++) {
            value a = val_array_ptr(arrs)[i];
            int j, max = val_array_size(a);
            for(j=0;j<max;j++)
                  val_array_ptr(all)[tot++] = val_array_ptr(a)[j];
      }
      return all;
}

/**   <doc><h2>String Builtins</h2></doc> **/

/**
      $string : any -> string
      <doc>Convert any value to a string. This will make a copy of string.</doc>
**/
static value builtin_string( value v ) {
      buffer b = alloc_buffer(NULL);
      val_buffer(b,v);
      return buffer_to_string(b);
}

/**
      $smake : n:int -> string
      <doc>Return an uninitialized string of size [n]</doc>
**/
static value builtin_smake( value l ) {
      val_check(l,int);
      return alloc_empty_string( val_int(l) );
}

/**
      $ssize : string -> int
      <doc>Return the size of a string</doc>
**/
static value builtin_ssize( value s ) {
      val_check(s,string);
      return alloc_int(val_strlen(s));
}

/**
      $scopy : string -> string
      <doc>Make a copy of a string</doc>
**/
static value builtin_scopy( value s ) {
      val_check(s,string);
      return copy_string( val_string(s), val_strlen(s) );
}

/**
      $ssub : string -> p:int -> l:int -> string
      <doc>
      Return [l] chars starting at position [p] of a string.
      An error occurs if out of string bounds.
      </doc>
**/
static value builtin_ssub( value s, value p, value l ) {
      int pp , ll;
      val_check(s,string);
      val_check(p,int);
      val_check(l,int);
      pp = val_int(p);
      ll = val_int(l);
      if( pp < 0 || ll < 0 || pp + ll < 0 || pp + ll > val_strlen(s) )
            neko_error();
      return copy_string( val_string(s) + pp , ll );
}

/**
      $sget : string -> n:int -> int?
      <doc>Return the [n]th char of a string or [null] if out of bounds</doc>
**/
static value builtin_sget( value s, value p ) {
      int pp;
      val_check(s,string);
      val_check(p,int);
      pp = val_int(p);
      if( pp < 0 || pp >= val_strlen(s) )
            return val_null;
      return alloc_int( (unsigned char)(val_string(s)[pp]) );
}

/**
      $sset : string -> n:int -> c:int -> int?
      <doc>
      Set the [n]th char of a string to ([c] & 255).
      Returns the char set or [null] if out of bounds.
      </doc>
**/
static value builtin_sset( value s, value p, value c ) {
      int pp;
      unsigned char cc;
      val_check(s,string);
      val_check(p,int);
      val_check(c,int);
      pp = val_int(p);
      if( pp < 0 || pp >= val_strlen(s) )
            return val_null;
      cc = (unsigned char)val_int(c);
      val_string(s)[pp] = (char)cc;
      return alloc_int(cc);
}

/**
      $sblit : dst:string -> dst_pos:int -> src:string -> src_pos:int -> len:int -> void
      <doc>
      Copy [len] chars from [src_pos] of [src] to [dst_pos] of [dst].
      An error occurs if out of strings bounds.
      </doc>
**/
static value builtin_sblit( value dst, value dp, value src, value sp, value l ) {
      int dpp, spp, ll;
      val_check(dst,string);
      val_check(dp,int);
      val_check(src,string);
      val_check(sp,int);
      val_check(l,int);
      dpp = val_int(dp);
      spp = val_int(sp);
      ll = val_int(l);
      if( dpp < 0 || spp < 0 || ll < 0 || dpp + ll < 0 || spp + ll  < 0 || dpp + ll > val_strlen(dst) || spp + ll > val_strlen(src) )
            neko_error();
      memmove(val_string(dst)+dpp,val_string(src)+spp,ll);
      return val_true;
}

/**
      $sfind : src:string -> pos:int -> pat:string -> int
      <doc>
      Return the first position starting at [pos] in [src] where [pat] was found.
      Return null if not found. Error if [pos] is outside [src] bounds.
      </doc>
**/
static value builtin_sfind( value src, value pos, value pat ) {
      int p, l, l2;
      const char *ptr;
      val_check(src,string);
      val_check(pos,int);
      val_check(pat,string);
      p = val_int(pos);
      l = val_strlen(src);
      l2 = val_strlen(pat);
      if( p < 0 || p >= l )
            neko_error();
      ptr = val_string(src) + p;
      while( l - p >= l2 ) {
            if( memcmp(ptr,val_string(pat),l2) == 0 )
                  return alloc_int(p);
            p++;
            ptr++;
      }
      return val_null;
}

/** <doc><h2>Object Builtins</h2></doc> **/

/**
      $new : object? -> object
      <doc>Return a copy of the object or a new object if [null]</doc>
**/
static value builtin_new( value o ) {
      if( !val_is_null(o) && !val_is_object(o) )
            neko_error();
      return alloc_object(o);
}

/**
      $objget : o:any -> f:int -> any
      <doc>Return the field [f] of [o] or [null] if doesn't exists or [o] is not an object</doc>
**/
static value builtin_objget( value o, value f ) {
      if( !val_is_object(o) )
            return val_null; // keep dot-access semantics
      val_check(f,int);
      return val_field(o,val_int(f));
}

/**
      $objset : o:any -> f:int -> v:any -> any
      <doc>Set the field [f] of [o] to [v] and return [v] if [o] is an object or [null] if not</doc>
**/
static value builtin_objset( value o, value f, value v ) {
      if( !val_is_object(o) )
            return val_null; // keep dot-access semantics
      val_check(f,int);
      alloc_field(o,val_int(f),v);
      return v;
}

/**
      $objcall : o:any -> f:int -> args:array -> any
      <doc>Call the field [f] of [o] with [args] and return the value or [null] is [o] is not an object</doc>
**/
static value builtin_objcall( value o, value f, value args ) {
      if( !val_is_object(o) )
            return val_null; // keep dot-access semantics
      val_check(f,int);
      val_check(args,array);
      return val_ocallN(o,val_int(f),val_array_ptr(args),val_array_size(args));
}

/**
      $objfield : o:any -> f:int -> bool
      <doc>Return true if [o] is an object which have field [f]</doc>
**/
static value builtin_objfield( value o, value f ) {
      val_check(f,int);
      return alloc_bool( val_is_object(o) && otable_find(((vobject*)o)->table, val_int(f)) != NULL );
}

/**
      $objremove : o:object -> f:int -> bool
      <doc>Remove the field [f] from object [o]. Return [true] on success</doc>
**/
static value builtin_objremove( value o, value f ) {
      val_check(o,object);
      val_check(f,int);
      return alloc_bool( otable_remove(((vobject*)o)->table,val_int(f)) );
}

static void builtin_objfields_rec( value d, field id, void *a ) {
      *((*(value**)a)++) = alloc_int((int)id);
}

/**
      $objfields : o:object -> int array
      <doc>Return all fields of the object</doc>
**/
static value builtin_objfields( value o ) {
      value a;
      value *aptr;
      objtable t;
      val_check(o,object);
      t = ((vobject*)o)->table;
      a = alloc_array(otable_count(t));
      aptr = val_array_ptr(a);
      otable_iter(t,builtin_objfields_rec,&aptr);
      return a;
}

/**
      $hash : string -> int
      <doc>Return the hashed value of a field name</doc>
**/
static value builtin_hash( value f ) {
      val_check(f,string);
      return alloc_int( (int)val_id(val_string(f)) );
}

/**
      $field : int -> string
      <doc>Reverse the hashed value of a field name. Return [null] on failure</doc>
**/
static value builtin_field( value f ) {
      val_check(f,int);
      return val_field_name(val_int(f));
}

/**
      $objsetproto : o:object -> proto:object? -> void
      <doc>Set the prototype of the object</doc>
**/
static value builtin_objsetproto( value o, value p ) {
      val_check(o,object);
      if( val_is_null(p) )
            ((vobject*)o)->proto = NULL;
      else {
            val_check(p,object);
            ((vobject*)o)->proto = (vobject*)p;
      }
      return val_true;
}

/**
      $objgetproto : o:object -> object?
      <doc>Get the prototype of the object</doc>
**/
static value builtin_objgetproto( value o ) {
      val_check(o,object);
      o = (value)((vobject*)o)->proto;
      if( o == NULL )
            return val_null;
      return o;
}

/** <doc><h2>Function Builtins</h2></doc> **/

/**
      $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) );
}

/**
      $call : f:function -> this:any -> args:array -> any
      <doc>Call [f] with [this] context and [args] arguments</doc>
**/
static value builtin_call( value f, value ctx, value args ) {
      value old;
      value ret;
      neko_vm *vm;
      val_check(args,array);
      vm = NEKO_VM();
      old = vm->vthis;
      vm->vthis = ctx;
      ret = val_callN(f,val_array_ptr(args),val_array_size(args));
      vm->vthis = old;
      return ret;
}

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);
}

/**
      $closure : function -> 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;
}

/**
      $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);
}

static value varargs_callback( value *args, int nargs ) {
      value f = NEKO_VM()->env;
      value a = alloc_array(nargs);
      int i;
      for(i=0;i<nargs;i++)
            val_array_ptr(a)[i] = args[i];
      return val_call1(f,a);
}

/**
      $varargs : f:function:1 -> function
      <doc>
      Return a variable argument function that, when called, will callback
      [f] with the array of arguments.
      </doc>
**/
static value builtin_varargs( value f ) {
      value fvar;
      val_check_function(f,1);
      fvar = alloc_function(varargs_callback,VAR_ARGS,"varargs");
      ((vfunction*)fvar)->env = f;
      return fvar;
}

/** <doc><h2>Number Builtins</h2></doc> **/

/**
      $iadd : any -> any -> int
      <doc>Add two integers</doc>
**/
static value builtin_iadd( value a, value b ) {
      return alloc_int( val_int(a) + val_int(b) );
}

/**
      $isub : any -> any -> int
      <doc>Subtract two integers</doc>
**/
static value builtin_isub( value a, value b ) {
      return alloc_int( val_int(a) - val_int(b) );
}

/**
      $imult : any -> any -> int
      <doc>Multiply two integers</doc>
**/
static value builtin_imult( value a, value b ) {
      return alloc_int( val_int(a) * val_int(b) );
}

/**
      $idiv : any -> any -> int
      <doc>Divide two integers. An error occurs if division by 0</doc>
**/
static value builtin_idiv( value a, value b ) {
      if( b == (value)1 )
            neko_error();
      return alloc_int( val_int(a) / val_int(b) );
}

typedef union {
      double d;
      struct {
            unsigned int l;
            unsigned int h;
      } i;
} qw;

/**
      $isnan : any -> bool
      <doc>Return if a value is the float NaN</doc>
**/
static value builtin_isnan( value f ) {
      qw q;
      unsigned int h, l;
      if( !val_is_float(f) )
            return val_false;
      q.d = val_float(f);
      h = q.i.h;
      l = q.i.l;
      l = l | (h & 0xFFFFF);
      h = h & 0x7FF00000;
      return alloc_bool( h == 0x7FF00000 && l != 0 );
}

/**
      $isinfinite : any -> bool
      <doc>Return if a value is the float +Infinite</doc>
**/
static value builtin_isinfinite( value f ) {
      qw q;
      unsigned int h, l;
      if( !val_is_float(f) )
            return val_false;
      q.d = val_float(f);
      h = q.i.h;
      l = q.i.l;
      l = l | (h & 0xFFFFF);
      h = h & 0x7FF00000;
      return alloc_bool( h == 0x7FF00000 && l == 0 );
}

/**
      $int : any -> int?
      <doc>Convert the value to the corresponding integer or return [null]</doc>
**/
static value builtin_int( value f ) {
      switch( val_type(f) ) {
      case VAL_FLOAT:
#ifdef      NEKO_WINDOWS
            return alloc_int((int)val_float(f));
#else
            // in case of overflow, the result is unspecified by ISO
            // so we have to make a module 2^32 before casting to int
            return alloc_int((unsigned int)fmod(val_float(f),4294967296.0));
#endif
      case VAL_STRING: {
            char *c = val_string(f);
            if( val_strlen(f) >= 2 && c[0] == '0' && c[1] == 'x' ) {
                  int h = 0;
                  c += 2;
                  while( *c ) {
                        char k = *c++;
                        if( k >= '0' && k <= '9' )
                              h = (h << 4) | (k - '0');
                        else if( k >= 'A' && k <= 'F' )
                              h = (h << 4) | ((k - 'A') + 10);
                        else if( k >= 'a' && k <= 'f' )
                              h = (h << 4) | ((k - 'a') + 10);
                        else
                              return alloc_int(0);
                  }
                  return alloc_int(h);
            }
            return alloc_int( atoi(val_string(f)) );
            }
      case VAL_INT:
            return f;
      }
      return val_null;
}

/**
      $float : any -> float?
      <doc>Convert the value to the corresponding float or return [null]</doc>
**/
static value builtin_float( value f ) {
      if( val_is_string(f) )
            return alloc_float( atof(val_string(f)) );
      if( val_is_number(f) )
            return alloc_float( val_number(f) );
      return val_null;
}

/** <doc><h2>Hashtable Builtins</h2></doc> **/

/**
      $hkey : any -> int
      <doc>Return the hash of any value</doc>
**/
static value builtin_hkey( value v ) {
      return alloc_int(val_hash(v));
}

#define HASH_DEF_SIZE 7

/**
      $hnew : s:int -> 'hash
      <doc>Create an hashtable with [s] slots</doc>
**/
static value builtin_hnew( value size ) {
      vhash *h;
      int i;
      val_check(size,int);
      h = (vhash*)alloc(sizeof(vhash));
      h->nitems = 0;
      h->ncells = val_int(size);
      if( h->ncells <= 0 )
            h->ncells = HASH_DEF_SIZE;
      h->cells = (hcell**)alloc(sizeof(hcell*)*h->ncells);
      for(i=0;i<h->ncells;i++)
            h->cells[i] = NULL;
      return alloc_abstract(k_hash,h);
}

static void add_rec( hcell **cc, int size, hcell *c ) {
      int k;
      if( c == NULL )
            return;
      add_rec(cc,size,c->next);
      k = c->hkey % size;
      c->next = cc[k];
      cc[k] = c;
}

/**
      $hresize : 'hash -> int -> void
      <doc>Resize an hashtable</doc>
**/
static value builtin_hresize( value vh, value size ) {
      vhash *h;
      hcell **cc;
      int nsize;
      int i;
      val_check_kind(vh,k_hash);
      val_check(size,int);
      h = val_hdata(vh);
      nsize = val_int(size);
      if( nsize <= 0 )
            nsize = HASH_DEF_SIZE;
      cc = (hcell**)alloc(sizeof(hcell*)*nsize);
      memset(cc,0,sizeof(hcell*)*nsize);
      for(i=0;i<h->ncells;i++)
            add_rec(cc,nsize,h->cells[i]);
      h->cells = cc;
      h->ncells = nsize;
      return val_true;
}

/**
      $hget : 'hash -> k:any -> cmp:function:2? -> any
      <doc>
            Look for the value bound to the key [k] in the hashtable.
            Use the comparison function [cmp] or [$compare] if [null].
            Return [null] if no value is found.
      </doc>
**/
static value builtin_hget( value vh, value key, value cmp ) {
      vhash *h;
      hcell *c;
      if( !val_is_null(cmp) )
            val_check_function(cmp,2);
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      c = h->cells[val_hash(key) % h->ncells];
      if( val_is_null(cmp) ) {
            while( c != NULL ) {
                  if( val_compare(key,c->key) == 0 )
                        return c->val;
                  c = c->next;
            }
      } else {
            while( c != NULL ) {
                  if( val_call2(cmp,key,c->key) == alloc_int(0) )
                        return c->val;
                  c = c->next;
            }
      }
      return val_null;
}

/**
      $hmem : 'hash -> k:any -> cmp:function:2? -> bool
      <doc>
            Look for the value bound to the key [k] in the hashtable.
            Use the comparison function [cmp] or [$compare] if [null].
            Return true if such value exists, false either.
      </doc>
**/
static value builtin_hmem( value vh, value key, value cmp ) {
      vhash *h;
      hcell *c;
      if( !val_is_null(cmp) )
            val_check_function(cmp,2);
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      c = h->cells[val_hash(key) % h->ncells];
      if( val_is_null(cmp) ) {
            while( c != NULL ) {
                  if( val_compare(key,c->key) == 0 )
                        return val_true;
                  c = c->next;
            }
      } else {
            while( c != NULL ) {
                  if( val_call2(cmp,key,c->key) == alloc_int(0) )
                        return val_true;
                  c = c->next;
            }
      }
      return val_false;
}

/**
      $hremove : 'hash -> k:any -> cmp:function:2? -> bool
      <doc>
            Look for the value bound to the key [k] in the hashtable.
            Use the comparison function [cmp] or [$compare] if [null].
            Return true if such value exists and remove it from the hash, false either.
      </doc>
**/
static value builtin_hremove( value vh, value key, value cmp ) {
      vhash *h;
      hcell *c, *prev = NULL;
      int hkey;
      if( !val_is_null(cmp) )
            val_check_function(cmp,2);
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      hkey = val_hash(key) % h->ncells;
      c = h->cells[hkey];
      if( val_is_null(cmp) ) {
            while( c != NULL ) {
                  if( val_compare(key,c->key) == 0 ) {
                        if( prev == NULL )
                              h->cells[hkey] = c->next;
                        else
                              prev->next = c->next;
                        h->nitems--;
                        return val_true;
                  }
                  prev = c;
                  c = c->next;
            }
      } else {
            while( c != NULL ) {
                  if( val_call2(cmp,key,c->key) == alloc_int(0) ) {
                        if( prev == NULL )
                              h->cells[hkey] = c->next;
                        else
                              prev->next = c->next;
                        h->nitems--;
                        return val_true;
                  }
                  prev = c;
                  c = c->next;
            }
      }
      return val_false;
}

/**
      $hset : 'hash -> k:any -> v:any -> cmp:function:2? -> bool
      <doc>
      Set the value bound to key [k] to [v] or add it to the hashtable if not found.
      Return true if the value was added to the hashtable.
      </doc>
**/
static value builtin_hset( value vh, value key, value val, value cmp ) {
      vhash *h;
      hcell *c;
      int hkey;
      if( !val_is_null(cmp) )
            val_check_function(cmp,2);
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      hkey = val_hash(key);
      c = h->cells[hkey % h->ncells];
      if( val_is_null(cmp) ) {
            while( c != NULL ) {
                  if( val_compare(key,c->key) == 0 ) {
                        c->val = val;
                        return val_false;
                  }
                  c = c->next;
            }
      } else {
            while( c != NULL ) {
                  if( val_call2(cmp,key,c->key) == alloc_int(0) ) {
                        c->val = val;
                        return val_false;
                  }
                  c = c->next;
            }
      }
      if( h->nitems >= (h->ncells << 1) )
            builtin_hresize(vh,alloc_int(h->ncells << 1));
      c = (hcell*)alloc(sizeof(hcell));
      c->hkey = hkey;
      c->key = key;
      c->val = val;
      hkey %= h->ncells;
      c->next = h->cells[hkey];
      h->cells[hkey] = c;
      h->nitems++;
      return val_true;
}

/**
      $hadd : 'hash -> k:any -> v:any -> void
      <doc>
      Add the value [v] with key [k] to the hashtable. Previous binding is masked but not removed.
      </doc>
**/
static value builtin_hadd( value vh, value key, value val ) {
      vhash *h;
      hcell *c;
      int hkey;
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      hkey = val_hash(key);
      if( hkey < 0 )
            neko_error();
      if( h->nitems >= (h->ncells << 1) )
            builtin_hresize(vh,alloc_int(h->ncells << 1));
      c = (hcell*)alloc(sizeof(hcell));
      c->hkey = hkey;
      c->key = key;
      c->val = val;
      hkey %= h->ncells;
      c->next = h->cells[hkey];
      h->cells[hkey] = c;
      h->nitems++;
      return val_true;
}

/**
      $hiter : 'hash -> f:function:2 -> void
      <doc>Call the function [f] with every key and value in the hashtable</doc>
**/
static value builtin_hiter( value vh, value f ) {
      int i;
      hcell *c;
      vhash *h;
      val_check_function(f,2);
      val_check_kind(vh,k_hash);
      h = val_hdata(vh);
      for(i=0;i<h->ncells;i++) {
            c = h->cells[i];
            while( c != NULL ) {
                  val_call2(f,c->key,c->val);
                  c = c->next;
            }
      }
      return val_null;
}

/**
      $hcount : 'hash -> int
      <doc>Return the number of elements in the hashtable</doc>
**/
static value builtin_hcount( value vh ) {
      val_check_kind(vh,k_hash);
      return alloc_int( val_hdata(vh)->nitems );
}

/**
      $hsize : 'hash -> int
      <doc>Return the size of the hashtable</doc>
**/
static value builtin_hsize( value vh ) {
      val_check_kind(vh,k_hash);
      return alloc_int( val_hdata(vh)->ncells );
}

/** <doc><h2>Other Builtins</h2></doc> **/

/**
      $print : any* -> void
      <doc>Can print any value</doc>
**/
static value builtin_print( value *args, int nargs ) {
      buffer b;
      int i;
      if( nargs == 1 && val_is_string(*args) ) {
            val_print(*args);
            return neko_builtins[1];
      }
      b = alloc_buffer(NULL);
      for(i=0;i<nargs;i++)
            val_buffer(b,args[i]);
      val_print(buffer_to_string(b));
      return neko_builtins[1];
}

/**
      $throw : any -> any
      <doc>Throw any value as an exception. Never returns</doc>
**/
static value builtin_throw( value v ) {
      val_throw(v);
      return val_null;
}

/**
      $rethrow : any -> any
      <doc>Throw any value as an exception while keeping previous exception stack. Never returns</doc>
**/
static value builtin_rethrow( value v ) {
      val_rethrow(v);
      return val_null;
}

/**
      $istrue : v:any -> bool
      <doc>Return true if [v] is not [false], not [null] and not 0</doc>
**/
static value builtin_istrue( value f ) {
      return alloc_bool(f != val_false && f != val_null && f != alloc_int(0));
}

/**
      $not : any -> bool
      <doc>Return true if [v] is [false] or [null] or [0]</doc>
**/
static value builtin_not( value f ) {
      return alloc_bool(f == val_false || f == val_null || f == alloc_int(0));
}

/**
      $typeof : any -> int
      <doc>
            Return the type of a value. The following builtins are defined :
            <ul>
                  <li>[$tnull] = 0</li>
                  <li>[$tint] = 1</li>
                  <li>[$tfloat] = 2</li>
                  <li>[$tbool] = 3</li>
                  <li>[$tstring] = 4</li>
                  <li>[$tobject] = 5</li>
                  <li>[$tarray] = 6</li>
                  <li>[$tfunction] = 7</li>
                  <li>[$tabstract] = 8</li>
            </ul>
      </doc>
**/
static value builtin_typeof( value v ) {
      switch( val_type(v) ) {
      case VAL_INT:
            return alloc_int(1);
      case VAL_NULL:
            return alloc_int(0);
      case VAL_FLOAT:
            return alloc_int(2);
      case VAL_BOOL:
            return alloc_int(3);
      case VAL_STRING:
            return alloc_int(4);
      case VAL_OBJECT:
            return alloc_int(5);
      case VAL_ARRAY:
            return alloc_int(6);
      case VAL_FUNCTION:
            return alloc_int(7);
      case VAL_ABSTRACT:
            return alloc_int(8);
      default:
            neko_error();
      }
}

/**
      $compare : any -> any -> int?
      <doc>Compare two values and return 1, -1 or 0. Return [null] if comparison is not possible</doc>
**/
static value builtin_compare( value a, value b ) {
      int r = val_compare(a,b);
      return (r == invalid_comparison)?val_null:alloc_int(r);
}

/**
      $pcompare : any -> any -> int
      <doc>Physically compare two values. Same as [$compare] for integers.</doc>
**/
static value builtin_pcompare( value a, value b ) {
      int_val ia = (int_val)a;
      int_val ib = (int_val)b;
      if( ia > ib )
            return alloc_int(1);
      else if( ia < ib )
            return alloc_int(-1);
      else
            return alloc_int(0);
}

/**
      $excstack : void -> array
      <doc>
      Return the stack between the place the last exception was raised and the place it was catched.
      The stack is composed of the following items :
      <ul>
            <li>[null] when it's a C function</li>
            <li>a string when it's a module without debug informations</li>
            <li>an array of two elements (usually file and line) if debug informations where available</li>
      </ul>
      </doc>
**/
static value builtin_excstack() {
      return NEKO_VM()->exc_stack;
}

/**
      $callstack : void -> array
      <doc>Return the current callstack. Same format as [$excstack]</doc>
**/
static value builtin_callstack() {
      return neko_call_stack(NEKO_VM());
}

/**
    $version : void -> int
      <doc>Return the version of Neko : 135 means 1.3.5</doc>
**/
static value builtin_version() {
      return alloc_int(NEKO_VERSION);
}

/**
      $setresolver : function:2? -> void
      <doc>Set a function to callback with object and field id when an object field is not found.</doc>
**/
static value builtin_setresolver( value f ) {
      neko_vm *vm = NEKO_VM();
      if( val_is_null(f) )
            vm->resolver = NULL;
      else {
            val_check_function(f,2);
            vm->resolver = f;
      }
      return val_null;
}

#define BUILTIN(name,nargs)   \
      alloc_field(neko_builtins[0],val_id(#name),alloc_function(builtin_##name,nargs,"$" #name));

void neko_init_builtins() {
      neko_builtins = alloc_root(2);
      neko_builtins[0] = alloc_object(NULL);
      neko_builtins[1] = alloc_function(builtin_print,VAR_ARGS,"$print");

      BUILTIN(print,VAR_ARGS);

      BUILTIN(array,VAR_ARGS);
      BUILTIN(amake,1);
      BUILTIN(acopy,1);
      BUILTIN(asize,1);
      BUILTIN(asub,3);
      BUILTIN(ablit,5);
      BUILTIN(aconcat,1);

      BUILTIN(smake,1);
      BUILTIN(ssize,1);
      BUILTIN(scopy,1);
      BUILTIN(ssub,3);
      BUILTIN(sget,2);
      BUILTIN(sset,3);
      BUILTIN(sblit,5);
      BUILTIN(sfind,3);

      BUILTIN(new,1);
      BUILTIN(objget,2);
      BUILTIN(objset,3);
      BUILTIN(objcall,3);
      BUILTIN(objfield,2);
      BUILTIN(objremove,2);
      BUILTIN(objfields,1);
      BUILTIN(hash,1);
      BUILTIN(field,1);
      BUILTIN(objsetproto,2);
      BUILTIN(objgetproto,1);

      BUILTIN(int,1);
      BUILTIN(float,1);
      BUILTIN(string,1);
      BUILTIN(typeof,1);
      BUILTIN(closure,VAR_ARGS);
      BUILTIN(apply,VAR_ARGS);
      BUILTIN(varargs,1);
      BUILTIN(compare,2);
      BUILTIN(pcompare,2);
      BUILTIN(not,1);
      BUILTIN(throw,1);
      BUILTIN(rethrow,1);
      BUILTIN(nargs,1);
      BUILTIN(call,3);
      BUILTIN(isnan,1);
      BUILTIN(isinfinite,1);
      BUILTIN(istrue,1);

      BUILTIN(hnew,1);
      BUILTIN(hget,3);
      BUILTIN(hmem,3);
      BUILTIN(hset,4);
      BUILTIN(hadd,3);
      BUILTIN(hremove,3);
      BUILTIN(hresize,2);
      BUILTIN(hkey,1);
      BUILTIN(hcount,1);
      BUILTIN(hsize,1);
      BUILTIN(hiter,2);

      BUILTIN(iadd,2);
      BUILTIN(isub,2);
      BUILTIN(imult,2);
      BUILTIN(idiv,2);

      BUILTIN(excstack,0);
      BUILTIN(callstack,0);
      BUILTIN(version,0);
      BUILTIN(setresolver,1);
}

/* ************************************************************************ */

Generated by  Doxygen 1.6.0   Back to index