kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-11-11 00:52:44 +03:00
Code Issues Projects Releases Wiki Activity
0a19c2f1c7
mal/c/types.c
Dov Murik 6b3ecaa769 c: Add Boehm garbage collector 
By default, garbage collection is enabled.  You can run:

    make USE_GC=

to build the C implementation without garbage collection.
2016-04-08 09:24:21 -04:00

521 lines
18 KiB
C
Raw Blame History

#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "types.h"
#include "printer.h"
#ifdef USE_GC
void nop_free(void* ptr) {
(void)ptr; // Unused argument
}
static GMemVTable gc_gmem_vtable = {
.malloc = GC_malloc,
.realloc = GC_realloc,
.free = nop_free,
.calloc = NULL,
.try_malloc = NULL,
.try_realloc = NULL
};
void GC_setup() {
GC_INIT();
setenv("G_SLICE", "always-malloc", 1);
g_mem_gc_friendly = TRUE;
g_mem_set_vtable(&gc_gmem_vtable);
}
char* GC_strdup(const char *src) {
if (!src) {
return NULL;
}
char* dst = (char*)MAL_GC_MALLOC(strlen(src) + 1);
strcpy(dst, src);
return dst;
}
#endif
// Errors/Exceptions
MalVal *mal_error = NULL; // WARNGIN: global state
void _error(const char *fmt, ...) {
va_list args;
va_start(args, fmt);
mal_error = malval_new_string(g_strdup_vprintf(fmt, args));
}
// Constant atomic values
MalVal mal_nil = {MAL_NIL, NULL, {0}, 0};
MalVal mal_true = {MAL_TRUE, NULL, {0}, 0};
MalVal mal_false = {MAL_FALSE, NULL, {0}, 0};
// General Functions
// Print a hash table
#include <glib-object.h>
void g_hash_table_print(GHashTable *hash_table) {
GHashTableIter iter;
gpointer key, value;
g_hash_table_iter_init (&iter, hash_table);
while (g_hash_table_iter_next (&iter, &key, &value)) {
g_print ("%s/%p ", (const char *) key, (void *) value);
//g_print ("%s ", (const char *) key);
}
}
GHashTable *g_hash_table_copy(GHashTable *src_table) {
GHashTable *new_table = g_hash_table_new(g_str_hash, g_str_equal);
GHashTableIter iter;
gpointer key, value;
g_hash_table_iter_init (&iter, src_table);
while (g_hash_table_iter_next (&iter, &key, &value)) {
g_hash_table_insert(new_table, key, value);
}
return new_table;
}
int min(int a, int b) { return a < b ? a : b; }
int max(int a, int b) { return a > b ? a : b; }
int _count(MalVal *obj) {
switch (obj->type) {
case MAL_NIL: return 0;
case MAL_LIST: return obj->val.array->len;
case MAL_VECTOR: return obj->val.array->len;
case MAL_HASH_MAP: return g_hash_table_size(obj->val.hash_table);
case MAL_STRING: return strlen(obj->val.string);
default:
_error("count unsupported for type %d\n", obj->type);
return 0;
}
}
// Allocate a malval and set its type and value
MalVal *malval_new(MalType type, MalVal *metadata) {
MalVal *mv = (MalVal*)MAL_GC_MALLOC(sizeof(MalVal));
mv->type = type;
mv->metadata = metadata;
return mv;
}
void malval_free(MalVal *mv) {
// TODO: free collection items
if (!(mv->type & (MAL_NIL|MAL_TRUE|MAL_FALSE))) {
MAL_GC_FREE(mv);
}
}
MalVal *malval_new_integer(gint64 val) {
MalVal *mv = malval_new(MAL_INTEGER, NULL);
mv->val.intnum = val;
return mv;
}
MalVal *malval_new_float(gdouble val) {
MalVal *mv = malval_new(MAL_FLOAT, NULL);
mv->val.floatnum = val;
return mv;
}
MalVal *malval_new_string(char *val) {
MalVal *mv = malval_new(MAL_STRING, NULL);
mv->val.string = val;
return mv;
}
MalVal *malval_new_symbol(char *val) {
MalVal *mv = malval_new(MAL_SYMBOL, NULL);
mv->val.string = val;
return mv;
}
MalVal *malval_new_keyword(char *val) {
MalVal *mv = malval_new(MAL_STRING, NULL);
mv->val.string = g_strdup_printf("\x7f%s", val);
return mv;
}
MalVal *malval_new_list(MalType type, GArray *val) {
MalVal *mv = malval_new(type, NULL);
mv->val.array = val;
return mv;
}
MalVal *malval_new_hash_map(GHashTable *val) {
MalVal *mv = malval_new(MAL_HASH_MAP, NULL);
mv->val.hash_table = val;
return mv;
}
MalVal *malval_new_atom(MalVal *val) {
MalVal *mv = malval_new(MAL_ATOM, NULL);
mv->val.atom_val = val;
return mv;
}
MalVal *malval_new_function(void *(*func)(void *), int arg_cnt) {
MalVal *mv = malval_new(MAL_FUNCTION_C, NULL);
mv->func_arg_cnt = arg_cnt;
assert(mv->func_arg_cnt <= 20,
"native function restricted to 20 args (%d given)",
mv->func_arg_cnt);
mv->ismacro = FALSE;
switch (arg_cnt) {
case -1: mv->val.f1 = (void *(*)(void*))func; break;
case 0: mv->val.f0 = (void *(*)())func; break;
case 1: mv->val.f1 = (void *(*)(void*))func; break;
case 2: mv->val.f2 = (void *(*)(void*,void*))func; break;
case 3: mv->val.f3 = (void *(*)(void*,void*,void*))func; break;
case 4: mv->val.f4 = (void *(*)(void*,void*,void*,void*))func; break;
case 5: mv->val.f5 = (void *(*)(void*,void*,void*,void*,void*))func; break;
case 6: mv->val.f6 = (void *(*)(void*,void*,void*,void*,void*,
void*))func; break;
case 7: mv->val.f7 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*))func; break;
case 8: mv->val.f8 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*))func; break;
case 9: mv->val.f9 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*))func; break;
case 10: mv->val.f10 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*))func; break;
case 11: mv->val.f11 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*))func; break;
case 12: mv->val.f12 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*))func; break;
case 13: mv->val.f13 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*))func; break;
case 14: mv->val.f14 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*))func; break;
case 15: mv->val.f15 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*))func; break;
case 16: mv->val.f16 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*))func; break;
case 17: mv->val.f17 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*))func; break;
case 18: mv->val.f18 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*))func; break;
case 19: mv->val.f19 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*))func; break;
case 20: mv->val.f20 = (void *(*)(void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*,
void*,void*,void*,void*,void*))func; break;
}
return mv;
}
MalVal *_apply(MalVal *f, MalVal *args) {
MalVal *res;
assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
"Cannot invoke %s", _pr_str(f,1));
if (f->type & MAL_FUNCTION_MAL) {
Env *fn_env = new_env(f->val.func.env, f->val.func.args, args);
res = f->val.func.evaluator(f->val.func.body, fn_env);
return res;
} else {
MalVal *a = args;
assert((f->func_arg_cnt == -1) ||
(f->func_arg_cnt == _count(args)),
"Length of formal params (%d) does not match actual parameters (%d)",
f->func_arg_cnt, _count(args));
switch (f->func_arg_cnt) {
case -1: res=f->val.f1 (a); break;
case 0: res=f->val.f0 (); break;
case 1: res=f->val.f1 (_nth(a,0)); break;
case 2: res=f->val.f2 (_nth(a,0),_nth(a,1)); break;
case 3: res=f->val.f3 (_nth(a,0),_nth(a,1),_nth(a,2)); break;
case 4: res=f->val.f4 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3)); break;
case 5: res=f->val.f5 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4)); break;
case 6: res=f->val.f6 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5)); break;
case 7: res=f->val.f7 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6)); break;
case 8: res=f->val.f8 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7)); break;
case 9: res=f->val.f9 (_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8)); break;
case 10: res=f->val.f10(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9)); break;
case 11: res=f->val.f11(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10)); break;
case 12: res=f->val.f12(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11)); break;
case 13: res=f->val.f13(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12)); break;
case 14: res=f->val.f14(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13)); break;
case 15: res=f->val.f15(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14)); break;
case 16: res=f->val.f16(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14),
_nth(a,15)); break;
case 17: res=f->val.f17(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14),
_nth(a,15),_nth(a,16)); break;
case 18: res=f->val.f18(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14),
_nth(a,15),_nth(a,16),_nth(a,17)); break;
case 19: res=f->val.f19(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14),
_nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18)); break;
case 20: res=f->val.f20(_nth(a,0),_nth(a,1),_nth(a,2),_nth(a,3),_nth(a,4),
_nth(a,5),_nth(a,6),_nth(a,7),_nth(a,8),_nth(a,9),
_nth(a,10),_nth(a,11),_nth(a,12),_nth(a,13),_nth(a,14),
_nth(a,15),_nth(a,16),_nth(a,17),_nth(a,18),_nth(a,19)); break;
}
return res;
}
}
int _equal_Q(MalVal *a, MalVal *b) {
GHashTableIter iter;
gpointer key, value;
if (a == NULL || b == NULL) { return FALSE; }
// If types are the same or both are sequential then they might be equal
if (!((a->type == b->type) ||
(_sequential_Q(a) && _sequential_Q(b)))) {
return FALSE;
}
switch (a->type) {
case MAL_NIL:
case MAL_TRUE:
case MAL_FALSE:
return a->type == b->type;
case MAL_INTEGER:
return a->val.intnum == b->val.intnum;
case MAL_FLOAT:
return a->val.floatnum == b->val.floatnum;
case MAL_SYMBOL:
case MAL_STRING:
if (strcmp(a->val.string, b->val.string) == 0) {
return TRUE;
} else {
return FALSE;
}
case MAL_LIST:
case MAL_VECTOR:
if (a->val.array->len != b->val.array->len) {
return FALSE;
}
int i;
for (i=0; i<a->val.array->len; i++) {
if (! _equal_Q(g_array_index(a->val.array, MalVal*, i),
g_array_index(b->val.array, MalVal*, i))) {
return FALSE;
}
}
return TRUE;
case MAL_HASH_MAP:
if (g_hash_table_size(a->val.hash_table) !=
g_hash_table_size(b->val.hash_table)) {
return FALSE;
}
g_hash_table_iter_init (&iter, a->val.hash_table);
while (g_hash_table_iter_next (&iter, &key, &value)) {
if (!g_hash_table_contains(b->val.hash_table, key)) {
return FALSE;
}
MalVal *aval = (MalVal *) g_hash_table_lookup(a->val.hash_table, key);
MalVal *bval = (MalVal *) g_hash_table_lookup(b->val.hash_table, key);
if (!_equal_Q(aval, bval)) {
return FALSE;
}
}
return TRUE;
case MAL_FUNCTION_C:
case MAL_FUNCTION_MAL:
return a->val.f0 == b->val.f0;
default:
_error("_equal_Q unsupported comparison type %d\n", a->type);
return FALSE;
}
}
// Lists
MalVal *_listX(int count, ...) {
MalVal *seq = malval_new_list(MAL_LIST,
g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
count));
MalVal *v;
va_list ap;
va_start(ap, count);
while (count-- > 0) {
v = va_arg(ap, MalVal*);
g_array_append_val(seq->val.array, v);
}
va_end(ap);
return seq;
}
MalVal *_list(MalVal *args) {
assert_type(args, MAL_LIST|MAL_VECTOR,
"list called with invalid arguments");
args->type = MAL_LIST;
return args;
}
int _list_Q(MalVal *seq) {
return seq->type & MAL_LIST;
}
// Vectors
MalVal *_vector(MalVal *args) {
assert_type(args, MAL_LIST|MAL_VECTOR,
"vector called with invalid arguments");
args->type = MAL_VECTOR;
return args;
}
int _vector_Q(MalVal *seq) {
return seq->type & MAL_VECTOR;
}
// Hash maps
MalVal *_hash_map(MalVal *args) {
assert_type(args, MAL_LIST|MAL_VECTOR,
"hash-map called with non-sequential arguments");
GHashTable *htable = g_hash_table_new(g_str_hash, g_str_equal);
MalVal *hm = malval_new_hash_map(htable);
return _assoc_BANG(hm, args);
}
int _hash_map_Q(MalVal *seq) {
return seq->type & MAL_HASH_MAP;
}
MalVal *_assoc_BANG(MalVal* hm, MalVal *args) {
assert((_count(args) % 2) == 0,
"odd number of parameters to assoc!");
GHashTable *htable = hm->val.hash_table;
int i;
MalVal *k, *v;
for (i=0; i<_count(args); i+=2) {
k = g_array_index(args->val.array, MalVal*, i);
assert_type(k, MAL_STRING,
"assoc! called with non-string key");
v = g_array_index(args->val.array, MalVal*, i+1);
g_hash_table_insert(htable, k->val.string, v);
}
return hm;
}
MalVal *_dissoc_BANG(MalVal* hm, MalVal *args) {
GHashTable *htable = hm->val.hash_table;
int i;
MalVal *k, *v;
for (i=0; i<_count(args); i++) {
k = g_array_index(args->val.array, MalVal*, i);
assert_type(k, MAL_STRING,
"dissoc! called with non-string key");
g_hash_table_remove(htable, k->val.string);
}
return hm;
}
// Atoms
int _atom_Q(MalVal *exp) {
return exp->type & MAL_ATOM;
}
// Sequence functions
MalVal *_slice(MalVal *seq, int start, int end) {
int i, new_len = max(0, min(end-start,
_count(seq)-start));
GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
new_len);
for (i=start; i<start+new_len; i++) {
g_array_append_val(new_arr, g_array_index(seq->val.array, MalVal*, i));
}
return malval_new_list(MAL_LIST, new_arr);
}
int _sequential_Q(MalVal *seq) {
return seq->type & (MAL_LIST|MAL_VECTOR);
}
MalVal *_nth(MalVal *seq, int idx) {
assert_type(seq, MAL_LIST|MAL_VECTOR,
"_nth called with non-sequential");
if (idx >= _count(seq)) {
abort("nth: index out of range");
}
return g_array_index(seq->val.array, MalVal*, idx);
}
MalVal *_first(MalVal *seq) {
assert_type(seq, MAL_NIL|MAL_LIST|MAL_VECTOR,
"_first called with non-sequential");
if (_count(seq) == 0) {
return &mal_nil;
}
return g_array_index(seq->val.array, MalVal*, 0);
}
MalVal *_last(MalVal *seq) {
assert_type(seq, MAL_LIST|MAL_VECTOR,
"_last called with non-sequential");
if (_count(seq) == 0) {
return &mal_nil;
}
return g_array_index(seq->val.array, MalVal*, _count(seq)-1);
}
MalVal *_rest(MalVal *seq) {
return _slice(seq, 1, _count(seq));
}
MalVal *_map2(MalVal *(*func)(void*, void*), MalVal *lst, void *arg2) {
MalVal *e, *el;
assert_type(lst, MAL_LIST|MAL_VECTOR,
"_map called with non-sequential");
int i, len = _count(lst);
el = malval_new_list(MAL_LIST,
g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len));
for (i=0; i<len; i++) {
e = func(g_array_index(lst->val.array, MalVal*, i), arg2);
if (!e || mal_error) return NULL;
g_array_append_val(el->val.array, e);
}
return el;
}
Reference in New Issue View Git Blame Copy Permalink