int list__to_tuple(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
data_t ret1;
checkf(list__length(args, 1, &ret1, scope) == 0, "Failed to find list length.");
int len = ret1.value.integral;
struct type **multiple = gc_add(scope->gc, malloc(sizeof(struct type *) * (len + 1)));
multiple[len] = NULL;
ret->value.tuple = gc_add(scope->gc, malloc(sizeof(data_t *) * (len + 1)));
ret->value.tuple[len] = NULL;
list_node_t *node;
list_iterator_t *it = list_iterator_new(args[0]->value.list, LIST_HEAD);
int i = 0;
while ((node = list_iterator_next(it))) {
ret->value.tuple[i] = copy_data((data_t *) node->val, scope);
multiple[i] = ret->value.tuple[i]->type;
check_mem(ret->value.tuple[i]);
++i;
}
ret->type = construct_type(tid_tuple, multiple, scope->gc);
if (it) list_iterator_destroy(it);
return 0;
error:
if (it) list_iterator_destroy(it);
return -1;
}
pobject moe_read(char *code)
{
int type, start, end = 0, dot_next = 0;
pobject stack = NIL;
while ((type = next_token(code, &start, &end))) {
switch (type) {
case TK_SYMBOL:
moe_read_stack_macro(stack, symbol_intern_by_slice(code, start, end));
break;
case TK_NUMBER:
moe_read_stack_macro(stack, gc_add( number_new_by_slice(code, start, end) ));
break;
case TK_PAREN_OPEN:
cons_stack_push(&stack, NIL, 1);
break;
case TK_PAREN_CLOSE:
moe_read_stack_macro(stack, cons_stack_pop(&stack));
break;
case TK_DOT:
dot_next = 1;
break;
}
};
return is_nil(stack) ? NIL : cons_car(cons_list_last(stack));
}
int list__construct(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
argc_t i;
data_t *data;
ret->value.list = gc_add_list(scope->gc, list_new());
check_mem(ret->value.list);
for (i = 0; i < argc; i++) {
if (!types_identical(args[0]->type, args[i]->type)) {
huserr__raise("typeErr", "list items must have one type", NULL, scope);
goto error;
}
data = gc_add(scope->gc, malloc(sizeof(data_t)));
check_mem(data);
data->type = typedup(args[i]->type, scope->gc);
data->value = args[i]->value;
check_mem(list_rpush(ret->value.list, list_node_new(data)));
}
ret->type = construct_type(tid_list, (argc > 0) ? itta(stt{
typedup(args[0]->type, scope->gc)
}, 1, scope->gc) : NULL, scope->gc);
return 0;
error:
return -1;
}
static pobject mod(pobject env, pobject params)
{
pobject o1 = eval(env, cons_nth(params, 1));
pobject o2 = eval(env, cons_nth(params, 2));
return (is_number(o1) && is_number(o2))
? gc_add((number_new( (int)number_value(o1) % (int)number_value(o2) )))
: NIL;
}
Identifier *put_symbol(GHashTable *sym_table, char *symbol, eType type)
{
Identifier *id = gc_malloc(IDENT_TYPE, sizeof(Identifier));
gc_add(CHAR_TYPE, id->symbol);
id->symbol = symbol;
id->type = type;
id->force_on_stack = false;
id->on_stack = false;
g_hash_table_insert(sym_table, symbol, id);
return id;
}
static pobject mult(pobject env, pobject params)
{
float result = 1;
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result *= number_value(o);
params = cons_cdr(params);
}
return gc_add(number_new(result));
}
static pobject defmacro(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(macro_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
int real__smaller(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
ret->type = construct_type(tid_atom, NULL, scope->gc);
ret->value.atom = gc_add(scope->gc, strdup(
(args[0]->value.real < args[1]->value.real) ? BOOLEAN_TRUE : BOOLEAN_FALSE
)
);
return 0;
}
r_value gc_new_al(int count)
{
gc_node* gc_p = NULL;
r_value ret = {0};
if( (gc_p=gc_add(gc_new_g_v_al(count), GC_LIVE))==0 )
return ret;
ret.r_t = sym_type_al;
ret.r_v.al = gc_p->gc_value.sg_v.al;
ret.gc_p = gc_p;
return ret;
}
void builtin_math_init(pobject *env)
{
cons_assoc_set(env, symbol_intern("*pi*"), gc_add(number_new(M_PI)), 1);
cons_assoc_set(env, symbol_intern("+"), gc_add(cfunc_new(plus)), 1);
cons_assoc_set(env, symbol_intern("-"), gc_add(cfunc_new(minus)), 1);
cons_assoc_set(env, symbol_intern("*"), gc_add(cfunc_new(mult)), 1);
cons_assoc_set(env, symbol_intern("/"), gc_add(cfunc_new(div)), 1);
cons_assoc_set(env, symbol_intern("mod"), gc_add(cfunc_new(mod)), 1);
}
static pobject define(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_symbol(p)) {
return env_define(env,
cons_car(params),
eval(env, cons_car(cons_cdr(params))));
} else if (is_cons(p)) {
return env_define(env,
cons_car(p),
gc_add(closure_new(env, cons_cdr(p), cons_cdr(params))));
}
return NIL;
}
int boolean__if(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
if (atom_is_true(args[0]->value.atom)) {
return performer__execute(args[1]->value.tree, scope, ret);
} else {
ret->type = construct_type(tid_atom, NULL, scope->gc);
ret->value.atom = gc_add(scope->gc, strdup("good"));
check_mem(ret->value.atom);
}
return 0;
error:
return -1;
}
t_lvar *lvar_new(void)
{
t_lvar *res;
if (!(res = malloc(sizeof(t_lvar))))
return (NULL);
if (!(res->val = malloc(sizeof(t_lptr))))
{
free(res);
return (NULL);
}
res->type = T_NULLP;
//res->next = 0;
res->gc_next = 0;
res->refcnt = 1;
gc_add(res);
return (res);
}
static pobject div(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result /= number_value(o); /* TODO: division by zero error handling */
params = cons_cdr(params);
}
}
}
return gc_add(number_new(result));
}
int list__head(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
if (args[0]->value.list->len == 0) {
scope->error = gc_add(scope->gc, malloc(sizeof(huserr_t)));
scope->error->token = NULL;
scope->error->name = "listErr";
scope->error->msg = "empty list has no head";
goto error;
}
ret->type = typedup(((data_t *) args[0]->value.list->head->val)->type, scope->gc);
ret->value = ((data_t *) args[0]->value.list->head->val)->value;
return 0;
error:
return -1;
}
static pobject minus(pobject env, pobject params)
{
float result = 0;
pobject o = eval(env, cons_car(params));
if (is_number(o)) {
result = number_value(o);
params = cons_cdr(params);
if (is_cons(params)) {
while (is_cons(params)) {
pobject o = eval(env, cons_car(params));
if (is_number(o))
result -= number_value(o);
params = cons_cdr(params);
}
} else {
result = -result;
}
}
return gc_add(number_new(result));
}
int real__to_string(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
REAL_TYPE n = args[0]->value.real;
if (n <= 0) {
n = -n + 1;
}
char *string = gc_add(scope->gc, malloc(sizeof(char) * (log10(n) + 2 + 20)));
check_mem(string);
sprintf(string, ((n < 0) ? "-%lf" : "%lf"), args[0]->value.real);
ret->type = construct_type(tid_string, NULL, scope->gc);
ret->value.string = string;
return 0;
error:
return -1;
}
gc_node* gc_add_str_table(char* str, e_gc_level gc_l)
{
unsigned int index =0;
str_node* str_p = NULL;
str_node* back_p = NULL;
gc_node* gc_p = NULL;
str_node* t_s_n = NULL;
if(str==NULL)
return NULL;
index = gc_hash(str);
str_p = alex_gc.gc_str_table.str_ptr[index];
back_p = str_p;
while(str_p)
{
if(alex_strcmp(str_p->str, str)== 0)
return str_p->gc_p;
back_p = str_p;
str_p = str_p->next;
}
t_s_n = (str_node*)a_malloc(sizeof(str_node));
memset(t_s_n, 0, sizeof(str_node));
gc_p = gc_add(gc_new_g_v_str(str), gc_l);
t_s_n->str = gc_p->gc_value.sg_v.str;
t_s_n->gc_p = gc_p;
if(back_p== NULL)
alex_gc.gc_str_table.str_ptr[index] = t_s_n;
else
back_p->next = t_s_n;
return gc_p;
}
void builtin_core_init(pobject *env)
{
cons_assoc_set(env, symbol_intern("nil"), NIL, 1);
cons_assoc_set(env, symbol_intern("#t"), object_true, 1);
cons_assoc_set(env, symbol_intern("#f"), NIL, 1);
cons_assoc_set(env, symbol_intern("quote"), gc_add(cfunc_new(quote)), 1);
cons_assoc_set(env, symbol_intern("print"), gc_add(cfunc_new(builtin_print)), 1);
cons_assoc_set(env, symbol_intern("println"), gc_add(cfunc_new(builtin_println)), 1);
cons_assoc_set(env, symbol_intern("begin"), gc_add(cfunc_new(begin)), 1);
cons_assoc_set(env, symbol_intern("cond"), gc_add(cfunc_new(cond)), 1);
cons_assoc_set(env, symbol_intern("set!"), gc_add(cfunc_new(set)), 1);
cons_assoc_set(env, symbol_intern("define"), gc_add(cfunc_new(define)), 1);
cons_assoc_set(env, symbol_intern("defmacro"), gc_add(cfunc_new(defmacro)), 1);
cons_assoc_set(env, symbol_intern("macro-expand"), gc_add(cfunc_new(builtin_macro_expand)), 1);
cons_assoc_set(env, symbol_intern("lambda"), gc_add(cfunc_new(lambda)), 1);
cons_assoc_set(env, symbol_intern("macro"), gc_add(cfunc_new(macro)), 1);
cons_assoc_set(env, symbol_intern("apply"), gc_add(cfunc_new(apply)), 1);
cons_assoc_set(env, symbol_intern("car"), gc_add(cfunc_new(car)), 1);
cons_assoc_set(env, symbol_intern("cdr"), gc_add(cfunc_new(cdr)), 1);
cons_assoc_set(env, symbol_intern("cons"), gc_add(cfunc_new(cons)), 1);
cons_assoc_set(env, symbol_intern("collect"), gc_add(cfunc_new(collect)), 1);
cons_assoc_set(env, symbol_intern("="), gc_add(cfunc_new(equal)), 1);
cons_assoc_set(env, symbol_intern(">"), gc_add(cfunc_new(gt)), 1);
}
static pobject cons(pobject env, pobject params)
{
pobject o1 = eval(env, cons_car(params));
pobject o2 = eval(env, cons_car(cons_cdr(params)));
return gc_add(cons_new(o1, o2));
}
static pobject macro(pobject env, pobject params)
{
return gc_add(macro_new(env, cons_car(params), cons_cdr(params)));
}
static pobject lambda(pobject env, pobject params)
{
return gc_add(closure_new(env, cons_car(params), cons_cdr(params)));
}
int list__unzip(data_t **args, argc_t argc, data_t *ret, scope_t *scope)
{
(void) argc;
ret->type = construct_type(tid_tuple, itta(stt{
construct_type(tid_list, itta(stt{
typedup(((data_t *) args[0]->value.list->head->val)->value.tuple[0]->type, scope->gc)
}, 1, scope->gc), scope->gc),
construct_type(tid_list, itta(stt{
typedup(((data_t *) args[0]->value.list->head->val)->value.tuple[1]->type, scope->gc)
}, 1, scope->gc), scope->gc),
}, 2, scope->gc), scope->gc);
check_mem(ret->type);
ret->value.tuple = gc_add(scope->gc, malloc(sizeof(data_t *) * 3));
check_mem(ret->value.list);
ret->value.tuple[0] = gc_add(scope->gc, malloc(sizeof(data_t)));
check_mem(ret->value.tuple[0]);
ret->value.tuple[1] = gc_add(scope->gc, malloc(sizeof(data_t)));
check_mem(ret->value.tuple[0]);
ret->value.tuple[0]->type = construct_type(tid_list, itta(stt{
typedup(((data_t *) args[0]->value.list->head->val)->value.tuple[0]->type, scope->gc)
}, 1, scope->gc), scope->gc);
ret->value.tuple[0]->value.list = gc_add(scope->gc, list_new());
check_mem(ret->value.tuple[0]->value.list);
ret->value.tuple[1]->type = construct_type(tid_list, itta(stt{
typedup(((data_t *) args[0]->value.list->head->val)->value.tuple[1]->type, scope->gc)
}, 1, scope->gc), scope->gc);
ret->value.tuple[1]->value.list = gc_add(scope->gc, list_new());
check_mem(ret->value.tuple[1]->value.list);
ret->value.tuple[2] = NULL;
list_node_t *node;
list_iterator_t *it = list_iterator_new(args[0]->value.list, LIST_HEAD);
while ((node = list_iterator_next(it))) {
list_rpush(ret->value.tuple[0]->value.list, gc_add(scope->gc, list_node_new(
copy_data(((data_t *) node->val)->value.tuple[0], scope))));
list_rpush(ret->value.tuple[1]->value.list, gc_add(scope->gc, list_node_new(
copy_data(((data_t *) node->val)->value.tuple[1], scope))));
}
// ret->value.tuple = gc_add(scope->gc, malloc(sizeof(data_t *) * 3));
// check_mem(ret->value.tuple);
// ret->value.tuple[0] = gc_add(scope->gc, malloc(sizeof(data_t)));
// check_mem(ret->value.tuple[0]);
// ret->value.tuple[0]->type = tid_tuple;
// ret->value.tuple[0]->value.tuple = gc_add(scope->gc, malloc(sizeof(data_t *) * (length + 1)));
// check_mem(ret->value.tuple[0]->value.tuple);
// ret->value.tuple[1] = gc_add(scope->gc, malloc(sizeof(data_t)));
// check_mem(ret->value.tuple[1]);
// ret->value.tuple[1]->type = tid_tuple;
// ret->value.tuple[1]->value.tuple = gc_add(scope->gc, malloc(sizeof(data_t *) * (length + 1)));
// check_mem(ret->value.tuple[1]->value.tuple);
// ret->value.tuple[2] = NULL;
// list_node_t *node;
// list_iterator_t *it = list_iterator_new(args[0]->value.list, LIST_HEAD);
// int i = 0;
// while ((node = list_iterator_next(it))) {
// if (((data_t *) node->val)->type != tid_tuple) {
// scope->error = gc_add(scope->gc, malloc(sizeof(huserr_t)));
// scope->error->name = "typeErr";
// scope->error->msg = "must be a zipped list";
// scope->error->token = NULL;
// goto error;
// }
// ret->value.tuple[0]->value.tuple[i] = copy_data(((data_t *) node->val)->value.tuple[0], scope);
// check_mem(ret->value.tuple[0]->value.tuple[i]);
// ret->value.tuple[1]->value.tuple[i] = copy_data(((data_t *) node->val)->value.tuple[1], scope);
// check_mem(ret->value.tuple[1]->value.tuple[i]);
// ++i;
// }
// ret->value.tuple[0]->value.tuple[i] = NULL;
// ret->value.tuple[1]->value.tuple[i] = NULL;
if (it) list_iterator_destroy(it);
return 0;
error:
if (it) list_iterator_destroy(it);
return -1;
}
