node_t quote_node(node_t node,int quote){
value_t value;
while(quote--){
value=alloc_value(SYMBOL,0);
value->string=unique_string("quote");
node=alloc_node(value,node);
node=alloc_node(alloc_value(LIST,node),0);
}
return node;
}
static value_t*
make_integer (long x)
{
integer_t *integer = (integer_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Integer), sizeof (integer_t));
integer->x = x;
return &integer->val;
}
static value_t*
make_string (const gchar *utf8)
{
string_t *s = (string_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_String), sizeof (string_t));
s->utf8 = utf8;
return &s->val;
}
static value_t*
make_vtable_value (closure_t **vtable)
{
vtable_value_t *val = (vtable_value_t*)alloc_value (NULL, sizeof (vtable_value_t));
val->vtable = vtable;
return &val->val;
}
static value_t *thunk_create(env_t *env, expr_t *expr)
{
value_t *v;
switch (expr->type) {
// Naively we could thunk everything, but there is no point
// thunking constants, data constructors or functions.
case p_bconst:
case p_cconst:
case p_datacons:
case p_listcons:
case p_listempty:
case p_listlit:
case p_nconst:
v = e_expr(env, expr);
break;
// As we construct environments incrementally, a variable must
// eventually be bound in 'env', but when we create this thunk
// that binding might not yet be present. (Imagine a binding of
// the form 'ones = 1:ones'.) So we thunk variables.
case p_var:
default:
v = alloc_value(v_thunk);
thunk_env(v) = env;
thunk_expr(v) = expr;
break;
}
return v;
}
static value_t*
make_character (gunichar c)
{
character_t *ch = (character_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Character), sizeof (character_t));
ch->c = c;
return &ch->val;
}
static value_t*
make_closure (function_t fn, environment_t *env)
{
closure_t *closure = (closure_t*) alloc_value (closure_ptable (), sizeof (closure_t));
closure->fn = fn;
closure->env = env;
return &closure->val;
}
// This is where most of the strict/lazy distinction is.
static value_t *e_fncall(env_t *env, expr_t *expr)
{
eli_closure_t c;
binding_t *fn;
// Call-by-value (strict function calls): evaluate each argument to
// a value in the given environment.
c.env = env;
c.list = list_empty();
list_iterate(fncall_args(expr), e_expr_list_i, &c);
list_reverse(c.list);
switch (fncall_fn(expr)->type) {
case p_var:
// The function is literally the name of a function, and is
// defined in the global environment.
fn = (binding_t *)env_lookup(global_env, var_name(fncall_fn(expr)));
assert(fn != NULL);
// We must have exactly as many arguments as parameters.
assert(list_length(c.list) == list_length(fn->params));
// Bind the function's parameters to the given arguments in a new
// scope derived from the global scope.
env = global_env;
env_new_scope(&env);
list_zip_with(fn->params,
c.list,
e_bind_params_i, env);
// Evaluate the function's body in the new environment.
return e_expr(env, fn->body);
case p_datacons:
{
value_t *result;
result = alloc_value(v_datacons);
datacons_tag(result) = datacons_tag(fncall_fn(expr));
datacons_params(result) = c.list;
// FIXME we'd like to assert that we got the right number of
// arguments, but we don't know how many the data constructor
// wanted.
return result;
}
default:
fprintf(stdout, "e_fncall: expression:\n");
pp_expr(stdout, fncall_fn(expr), 2);
fprintf(stdout, "\non line %d is not a function-variable or a data constructor.\n", fn->line_num);
error("");
return NULL;
}
}
static value_t *e_equals(env_t *env, expr_t *l, expr_t *r)
{
value_t *result;
result = alloc_value(v_bool);
bool_val(result) = equality_test(e_expr(env, l), e_expr(env, r));
return result;
}
static value_t*
make_string_from_unichar (gunichar c)
{
gchar *buf = GC_malloc (7);
string_t *s = (string_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_String), sizeof (string_t));
buf [g_unichar_to_utf8 (c, buf)] = '\0';
s->utf8 = buf;
return &s->val;
}
static value_t *e_datacons(env_t *env, expr_t *expr)
{
value_t *result;
result = alloc_value(v_datacons);
datacons_tag(result) = datacons_tag(expr);
datacons_params(result) = list_empty();
return result;
}
static value_t *e_listempty(void)
{
value_t *result;
result = alloc_value(v_datacons);
datacons_tag(result) = listEmptyTag;
datacons_params(result) = list_empty();
return result;
}
static value_t*
make_array (long len)
{
array_t *array = (array_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Array), sizeof (array_t) + len * sizeof (value_t*));
long i;
array->len = len;
for (i = 0; i < len; ++i)
array->elems [i] = value_nil;
return &array->val;
}
// Strict binary operators.
static value_t *e_binary_op(env_t *env, expr_t *expr)
{
value_t *result;
value_t *l;
value_t *r;
l = e_expr(env, binary_left(expr));
r = e_expr(env, binary_right(expr));
result = alloc_value(v_unused);
switch (expr->type) {
case p_add:
result->type = v_num;
num_val(result) = num_val(l) + num_val(r);
break;
case p_div:
result->type = v_num;
num_val(result) = num_val(l) / num_val(r);
break;
case p_ge:
result->type = v_bool;
bool_val(result) = num_val(l) >= num_val(r);
break;
case p_gt:
result->type = v_bool;
bool_val(result) = num_val(l) > num_val(r);
break;
case p_le:
result->type = v_bool;
bool_val(result) = num_val(l) <= num_val(r);
break;
case p_lt:
result->type = v_bool;
bool_val(result) = num_val(l) < num_val(r);
break;
case p_mod:
result->type = v_num;
num_val(result) = (long)num_val(l) % (long)num_val(r);
break;
case p_mul:
result->type = v_num;
num_val(result) = num_val(l) * num_val(r);
break;
case p_sub:
result->type = v_num;
num_val(result) = num_val(l) - num_val(r);
break;
default:
error("Not a strict binary operator.");
return NULL; // gcc dataflow
}
return result;
}
static void
cljc_init (void)
{
GC_INIT ();
PTABLE_NAME (cljc_DOT_core_SLASH_Nil) = alloc_ptable (TYPE_Nil);
PTABLE_NAME (cljc_DOT_core_SLASH_Integer) = alloc_ptable (TYPE_Integer);
PTABLE_NAME (cljc_DOT_core_SLASH_Boolean) = alloc_ptable (TYPE_Boolean);
PTABLE_NAME (cljc_DOT_core_SLASH_Array) = alloc_ptable (TYPE_Array);
PTABLE_NAME (cljc_DOT_core_SLASH_Character) = alloc_ptable (TYPE_Character);
PTABLE_NAME (cljc_DOT_core_SLASH_String) = alloc_ptable (TYPE_String);
value_nil = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Nil), sizeof (value_t));
value_true = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t));
value_false = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t));
VAR_NAME (cljc_DOT_core_SLASH_print) = make_closure (cljc_core_print, NULL);
VAR_NAME (cljc_DOT_core_SLASH_apply) = make_closure (cljc_core_apply, NULL);
}
static value_t*
make_string_copy_free (gchar *utf8)
{
size_t len = strlen (utf8);
gchar *copy = GC_malloc (len + 1);
string_t *s = (string_t*) alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_String), sizeof (string_t));
strcpy (copy, utf8);
free (utf8);
s->utf8 = copy;
return &s->val;
}
// FIXME this is pretty ugly.
static value_t *e_listlit_rec(env_t *env, list_t *exprs, int i, int limit)
{
value_t *result;
if (i < limit) {
value_t *list_elt = thunk_create(env, list_nth(exprs, i));
result = alloc_value(v_datacons);
datacons_tag(result) = listConsTag;
datacons_params(result) = list_cons(list_elt,
list_cons(e_listlit_rec(env, exprs, i + 1, limit),
list_empty()));
} else {
result = alloc_value(v_datacons);
datacons_tag(result) = listEmptyTag;
datacons_params(result) = list_empty();
}
return result;
}
/*@
* @deftypefun jit_value_t jit_value_create_nint_constant (jit_function_t @var{func}, jit_type_t @var{type}, jit_nint @var{const_value})
* Create a new native integer constant in the specified function.
* Returns NULL if out of memory.
*
* The @var{type} parameter indicates the actual type of the constant,
* if it happens to be something other than @code{jit_type_nint}.
* For example, the following will create an unsigned byte constant:
*
* @example
* value = jit_value_create_nint_constant(func, jit_type_ubyte, 128);
* @end example
*
* This function can be used to create constants of type @code{jit_type_sbyte},
* @code{jit_type_ubyte}, @code{jit_type_short}, @code{jit_type_ushort},
* @code{jit_type_int}, @code{jit_type_uint}, @code{jit_type_nint},
* @code{jit_type_nuint}, and all pointer types.
* @end deftypefun
@*/
jit_value_t
jit_value_create_nint_constant(jit_function_t func, jit_type_t type, jit_nint const_value)
{
jit_type_t stripped = 0;
if(!const_value)
{
/* Special cases: see if this is the NULL or zero constant */
stripped = jit_type_remove_tags(type);
if(stripped->kind == JIT_TYPE_SIGNATURE
|| stripped->kind == JIT_TYPE_PTR
|| stripped->kind == JIT_TYPE_NINT)
{
if(func && func->builder && func->builder->null_constant)
{
return func->builder->null_constant;
}
}
else if(stripped->kind == JIT_TYPE_INT)
{
if(func && func->builder && func->builder->zero_constant)
{
return func->builder->zero_constant;
}
}
}
jit_value_t value = alloc_value(func, type);
if(!value)
{
return 0;
}
value->is_constant = 1;
value->is_nint_constant = 1;
value->address = const_value;
if(stripped)
{
/* Special cases: see if we need to cache this constant for later */
if(stripped->kind == JIT_TYPE_SIGNATURE
|| stripped->kind == JIT_TYPE_PTR
|| stripped->kind == JIT_TYPE_NINT)
{
func->builder->null_constant = value;
}
else if(stripped->kind == JIT_TYPE_INT)
{
func->builder->zero_constant = value;
}
}
return value;
}
int
k5_json_bool_create(int truth, k5_json_bool *val_out)
{
k5_json_bool b;
*val_out = NULL;
b = alloc_value(&bool_type, 1);
if (b == NULL)
return ENOMEM;
*(unsigned char *)b = !!truth;
*val_out = b;
return 0;
}
node_t new_node(int type,char* string){
value_t value;
char* str_end;
value=alloc_value(type,0);
if(string){ /* define with a string */
value->number=strtod(string,&str_end); /* test if `string' is a number */
if(*str_end){ /* failed */
value->string=string;
}else{ /* success */
value->type=NUMBER;
}
}
return alloc_node(value,0);
}
/*@
* @deftypefun jit_value_t jit_value_create (jit_function_t @var{func}, jit_type_t @var{type})
* Create a new value in the context of a function's current block.
* The value initially starts off as a block-specific temporary.
* It will be converted into a function-wide local variable if
* it is ever referenced from a different block. Returns NULL
* if out of memory.
*
* Note: It isn't possible to refer to global variables directly using
* values. If you need to access a global variable, then load its
* address into a temporary and use @code{jit_insn_load_relative}
* or @code{jit_insn_store_relative} to manipulate it. It simplifies
* the JIT if it can assume that all values are local.
* @end deftypefun
@*/
jit_value_t
jit_value_create(jit_function_t func, jit_type_t type)
{
jit_value_t value = alloc_value(func, type);
if(!value)
{
return 0;
}
value->is_temporary = 1;
if(jit_type_has_tag(type, JIT_TYPETAG_VOLATILE))
{
value->is_volatile = 1;
}
return value;
}
static value_t *e_tuple(env_t *env, expr_t *expr)
{
value_t *result;
eli_closure_t c;
c.env = env;
c.list = list_empty();
list_iterate(tuple_val(expr), thunk_list_i, &c);
list_reverse(c.list);
result = alloc_value(v_tuple);
tuple_val(result) = c.list;
return result;
}
static value_t *e_listcons(env_t *env, expr_t *expr)
{
value_t *result;
value_t *head;
value_t *tail;
head = e_expr(env, binary_left(expr));
tail = e_expr(env, binary_right(expr));
result = alloc_value(v_datacons);
datacons_tag(result) = listConsTag;
datacons_params(result) = list_cons(head, list_cons(tail, list_empty()));
return result;
}
node_t stream2node(FILE*stream){
node_t head,cur;
value_t value;
char ch;
unsigned n;
int inside_string,quote;
head=alloc_node(0,0);
cur=head;
n=0; inside_string=0; quote=0;
while((ch=fgetc(stream))!=EOF){
if(ch=='\\'){ BUFFER[n++]=fgetc(stream); continue; }
if(inside_string){
if(ch=='"'){
if(n>0){ cur->cdr=quote_node(new_node(STRING,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
inside_string=0;
}else{ BUFFER[n++]=ch; }
continue;
}
if(ch==')'){ break;} /* return list */
switch(ch){
case ';': /* start a commit line */
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
while((ch=fgetc(stream))!='\n'&&ch!=EOF);
break;
case '"': /* start a string */
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
inside_string=1;
break;
case '(': /* start a list */
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
cur->cdr=stream2node(stream); cur=cur->cdr;
break;
case '`': /* start a quote */
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
quote++;
break;
default:
if(isspace(ch)){ /* if space */
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
}else{ BUFFER[n++]=ch; }
break;
}
}
if(n>0){ cur->cdr=quote_node(new_node(SYMBOL,new_string(BUFFER,n)),quote); cur=cur->cdr; n=0; quote=0;}
value=alloc_value(LIST,head->cdr);
head->car=value; head->cdr=0;
return head;
}
static value_t *e_listcons(env_t *env, expr_t *expr)
{
value_t *result;
value_t *head;
value_t *tail;
// "CONS should not evaluate its arguments."
head = thunk_create(env, binary_left(expr));
tail = thunk_create(env, binary_right(expr));
result = alloc_value(v_datacons);
datacons_tag(result) = listConsTag;
datacons_params(result) = list_cons(head, list_cons(tail, list_empty()));
return result;
}
/*@
* @deftypefun jit_value_t jit_value_create_nfloat_constant (jit_function_t @var{func}, jit_type_t @var{type}, jit_nfloat @var{const_value})
* Create a new native floating-point constant in the specified
* function. Returns NULL if out of memory.
* @end deftypefun
@*/
jit_value_t
jit_value_create_nfloat_constant(jit_function_t func, jit_type_t type, jit_nfloat const_value)
{
jit_value_t value = alloc_value(func, type);
if(!value)
{
return 0;
}
value->is_constant = 1;
value->address = (jit_nint) jit_malloc(sizeof(jit_nfloat));
if(!value->address)
{
return 0;
}
*((jit_nfloat *) value->address) = const_value;
value->free_address = 1;
return value;
}
static int add_binding_i(void *data, void *info)
{
binding_t *b = (binding_t *)data;
env_t *env = (env_t *)info;
value_t *v;
if (b->type->type == t_fn) {
// A function, allocate a closure.
v = alloc_value(v_closure);
closure_params(v) = b->params;
closure_body(v) = b->body;
closure_env(v) = env;
} else {
// Body is constant, thunk it.
v = thunk_create(env, b->body);
}
env_add_binding(env, b->name, v);
return 1;
}
/*@
* @deftypefun jit_value_t jit_value_create_long_constant (jit_function_t @var{func}, jit_type_t @var{type}, jit_long @var{const_value})
* Create a new 64-bit integer constant in the specified
* function. This can also be used to create constants of
* type @code{jit_type_ulong}. Returns NULL if out of memory.
* @end deftypefun
@*/
jit_value_t
jit_value_create_long_constant(jit_function_t func, jit_type_t type, jit_long const_value)
{
jit_value_t value = alloc_value(func, type);
if(!value)
{
return 0;
}
value->is_constant = 1;
#ifdef JIT_NATIVE_INT64
value->is_nint_constant = 1;
value->address = (jit_nint) const_value;
#else
value->address = (jit_nint) jit_malloc(sizeof(jit_long));
if(!value->address)
{
return 0;
}
*((jit_long *) value->address) = const_value;
value->free_address = 1;
#endif
return value;
}
int
k5_json_array_create(k5_json_array *val_out)
{
*val_out = alloc_value(&array_type, sizeof(struct k5_json_array_st));
return (*val_out == NULL) ? ENOMEM : 0;
}
int
k5_json_null_create_val(k5_json_value *val_out)
{
*val_out = alloc_value(&null_type, 0);
return (*val_out == NULL) ? ENOMEM : 0;
}
