aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/csx.c604
1 files changed, 499 insertions, 105 deletions
diff --git a/src/csx.c b/src/csx.c
index b6b0d38..abf94aa 100644
--- a/src/csx.c
+++ b/src/csx.c
@@ -5,163 +5,557 @@
#include <string.h>
-enum { type_nil, type_pair, type_string, type_atom, type_fn };
-static int *type(char *p) { return (int *) (p - sizeof(int)); }
-static void type_shift(void *p) { *(char **)p += sizeof(int); }
-static void *type_alloc(int t, int content_size)
-{
- int *res = malloc(sizeof(int) + content_size);
- *res = t;
- type_shift(&res);
- return res;
+typedef enum csx_type {
+ type_null,
+ type_pair,
+ type_name,
+ type_base,
+ type_num,
+ type_fn
+} csx_type;
+
+
+/* typedef void null_data; */
+
+typedef struct pair_data {
+ void *head;
+ void *tail;
+} pair_data;
+
+/* typedef char name_data; */
+
+typedef csx_base_data base_data;
+
+/* typedef int num_data; */
+
+typedef struct fn_data {
+ pair_data *params;
+ pair_data *body;
+ pair_data *context;
+} fn_data;
+
+
+static csx_type type(void *p)
+{
+ return *((int *)p - 1);
}
+static void *new(csx_type type, int data_size)
+{
+ int *res = malloc(sizeof(int) + data_size);
+ if (!res) exit(1);
+ *res = type;
+ return res + 1;
+}
-struct deflist {
- char *atom;
- void *data;
- struct deflist *next;
-};
-static struct state {
- struct deflist *atoms;
-} csx;
-static int csx_to_init = 0;
+static void *new_null()
+{
+ return new(type_null, 0);
+}
+
+static pair_data *new_pair(void *head, void *tail)
+{
+ pair_data *res = new(type_pair, sizeof(pair_data));
+ res->head = head;
+ res->tail = tail;
+ return res;
+}
-static void *nil;
+static char *new_name(const char *name)
+{
+ int namesize = strlen(name) + 1;
+ void *res = new(type_name, namesize);
+ memcpy(res, name, namesize);
+ return res;
+}
+static base_data *new_base(base_data base)
+{
+ base_data *res = new(type_base, sizeof(base_data));
+ *res = base;
+ return res;
+}
-static void adddef(struct deflist **l, const char *atom, void *data)
+static int *new_num(int num)
{
- struct deflist *old = *l;
- *l = malloc(sizeof(**l));
- (*l)->next = old;
- (*l)->atom = scopy(atom);
- (*l)->data = data;
+ int *res = new(type_num, sizeof(int));
+ *res = num;
+ return res;
}
-static void *csx_fn_new(void *fn, void *userdata, int size)
+static fn_data *new_fn(void *params, void *body, void *context)
{
- void *res = malloc(sizeof(fn) + sizeof(int) + size);
- *(void **)res = fn;
- (char *)res += sizeof(fn);
- *(int *)res = type_fn;
- typeshift(&res);
- if (userdata && size) memcpy(res, userdata, size);
+ fn_data *res = new(type_fn, sizeof(fn_data));
+ res->params = params;
+ res->body = body;
+ res->context = context;
return res;
}
-static void *define(void *userdata, struct csx_pair *data)
-{ /* TODO! */
- int t = *type(data);
- if (t != type_pair) return nil;
- t = *type(data->car);
- if (t == type_atom) {
- struct csx_pair *cdr = data->cdr;
- if (*type(cdr) != type_pair || *type(cdr->cdr) != type_nil)
- return nil;
- return define_constant(data->car, cdr->cdr);
+
+static void *head(pair_data *pair) { return pair->head; }
+static void *tail(pair_data *pair) { return pair->tail; }
+
+
+static int initiated = 0;
+static void *null;
+static void *one;
+static pair_data *context;
+
+
+static void *lookup_frame(const char *name)
+{
+ void *frame = head(context);
+ while (type(frame) == type_pair) {
+ if (!strcmp(head(head(frame)), name)) return head(frame);
+ frame = tail(frame);
+ }
+ return null;
+}
+
+static void *lookup(const char *name)
+{
+ void *saved = context;
+ while (type(context) == type_pair) {
+ void *res = lookup_frame(name);
+ if (type(res) != type_null) {
+ context = saved;
+ return res;
+ }
+ context = tail(context);
+ }
+ context = saved;
+ return null;
+}
+
+static void *base_define(void *arg)
+{
+ pair_data *res;
+ void *name = head(arg);
+ void *value = head(tail(arg));
+ if (type(context) == type_null) {
+ void *nameval = new_pair(name, value);
+ context = new_pair(new_pair(nameval, null), null);
+ return null;
+ }
+ res = lookup_frame(name);
+ if (type(res) != type_null) {
+ res->tail = value;
+ } else {
+ void **names = &context->head;
+ *names = new_pair(new_pair(name, value), *names);
}
- return define_function(data->car, data->cdr);
+ return null;
}
-/* TODO append, cdr, ... */
-static void csx_init()
+static void *eval_each(void *l);
+
+
+static void *base_not(void *arg)
{
- if (!csx_to_init) csx_free();
- csx.atoms = 0;
+ arg = eval_each(arg);
+ return type(head(arg)) == type_null ? one : null;
+}
- nil = type_alloc(type_nil, 0);
- adddef(csx.atoms, "append", csx_fn_new(append, 0, 0));
- adddef(csx.atoms, "define", csx_fn_new(define, 0, 0));
- adddef(csx.atoms, "cdr", csx_fn_new(cdr, 0, 0));
- adddef(csx.atoms, "ifx", csx_fn_new(ifx, 0, 0));
- adddef(csx.atoms, "not", csx_fn_new(not, 0, 0));
+static void *base_is_pair(void *arg)
+{
+ arg = eval_each(arg);
+ return type(head(arg)) == type_pair ? one : null;
}
-void csx_free()
+static void *base_is_name(void *arg)
{
- free(nil);
- /* free everything allocated */
- csx_to_init = 0;
+ arg = eval_each(arg);
+ return type(head(arg)) == type_name ? one : null;
}
+static void *base_is_base(void *arg)
+{
+ arg = eval_each(arg);
+ return type(head(arg)) == type_base ? one : null;
+}
-struct csx_pair *csx_pair_new(void *car, void *cdr)
+static void *base_is_num(void *arg)
{
- struct csx_pair *res =type_alloc(type_pair, sizeof(*res));
- res->car = car;
- res->cdr = cdr;
- return res;
+ arg = eval_each(arg);
+ return type(head(arg)) == type_num ? one : null;
+}
+
+static void *base_is_fn(void *arg)
+{
+ arg = eval_each(arg);
+ return type(head(arg)) == type_fn ? one : null;
}
+static void *base_sum(void *arg)
+{
+ arg = eval_each(arg);
+ int res = 0;
+ while (type(arg) == type_pair) {
+ void *num = head(arg);
+ if (type(num) != type_num) exit(1);
+ res += *(int *)num;
+ arg = tail(arg);
+ }
+ return new_num(res);
+}
-struct csx_pair *csx_list(void *head, ...)
+static void *base_diff(void *arg)
{
- struct csx_pair *res;
- va_list args;
- if (csx_to_init) csx_init();
- if (!head) return nil;
+ arg = eval_each(arg);
+ return new_num(*(int *)head(arg) - *(int *)head(tail(arg)));
+}
- res = csx_pair_new(head, nil);
- va_start(args, head);
- for (head = va_arg(args, void *); head; head = va_arg(args, void *)) {
- res->cdr = csx_pair_new(head, nil);
+static void *base_prod(void *arg)
+{
+ arg = eval_each(arg);
+ int res = 1;
+ while (type(arg) == type_pair) {
+ void *num = head(arg);
+ if (type(num) != type_num) exit(1);
+ res *= *(int *)num;
+ arg = tail(arg);
+ }
+ return new_num(res);
+}
+
+static void *base_div(void *arg)
+{
+ arg = eval_each(arg);
+ return new_num(*(int *)head(arg) / *(int *)head(tail(arg)));
+}
+
+static void *base_mod(void *arg)
+{
+ arg = eval_each(arg);
+ return new_num(*(int *)head(arg) % *(int *)head(tail(arg)));
+}
+
+static void *base_id(void *arg)
+{
+ arg = eval_each(arg);
+ return arg;
+}
+
+static void *base_and(void *arg)
+{
+ arg = eval_each(arg);
+ while (type(arg) == type_pair) {
+ if (type(head(arg)) == type_null) return null;
+ arg = tail(arg);
+ }
+ return one;
+}
+
+static void *base_or(void *arg)
+{
+ arg = eval_each(arg);
+ while (type(arg) == type_pair) {
+ if (type(head(arg)) != type_null) return one;
+ arg = tail(arg);
+ }
+ return null;
+}
+
+
+static void *base_eq(void *arg);
+
+static void *eqpair(void *a, void *rest)
+{
+ while (type(rest) == type_pair) {
+ void *res;
+ void *another = head(rest);
+ if (type(another) != type_pair) return null;
+ res = base_eq(new_pair(head(a), new_pair(head(another), null)));
+ if (type(res) == type_null) return null;
+ res = base_eq(new_pair(tail(a), new_pair(tail(another), null)));
+ if (type(res) == type_null) return null;
+ rest = tail(rest);
+ }
+ return one;
+}
+
+static void *eqname(char *a, void *rest)
+{
+ while (type(rest) == type_pair) {
+ char *another = head(rest);
+ if (type(another) != type_name || strcmp(another, a)) return null;
+ rest = tail(rest);
+ }
+ return one;
+}
+
+static void *eqnum(int *a, void *rest)
+{
+ int num = *a;
+ while (type(rest) == type_pair) {
+ int *another = head(rest);
+ if (type(another) != type_num || *another != num) return null;
+ rest = tail(rest);
+ }
+ return one;
+}
+
+static void *base_eq(void *arg)
+{
+ arg = eval_each(arg);
+ void *a;
+ void *rest;
+ if (type(arg) != type_pair) return null;
+ a = head(arg);
+ rest = tail(arg);
+ if (type(a) == type_pair) return eqpair(a, rest);
+ if (type(a) == type_name) return eqname(a, rest);
+ if (type(a) == type_num) return eqnum(a, rest);
+ while (type(rest) == type_pair) {
+ void *another = head(rest);
+ if (another != a) return null;
+ rest = tail(rest);
+ }
+ return one;
+}
+
+
+static void *base_inc(void *arg)
+{
+ arg = eval_each(arg);
+ if (type(arg) != type_pair || type(head(arg)) != type_num) return null;
+ int num = *(int *)head(arg);
+ arg = tail(arg);
+ while (type(arg) == type_pair) {
+ int *another = head(arg);
+ if (type(another) != type_num || *another <= num) return null;
+ num = *another;
+ arg = tail(arg);
+ }
+ return one;
+}
+
+static void *base_dec(void *arg)
+{
+ arg = eval_each(arg);
+ if (type(arg) != type_pair || type(head(arg)) != type_num) return null;
+ int num = *(int *)head(arg);
+ arg = tail(arg);
+ while (type(arg) == type_pair) {
+ int *another = head(arg);
+ if (type(another) != type_num || *another >= num) return null;
+ num = *another;
+ arg = tail(arg);
+ }
+ return one;
+}
+
+static void *base_pair(void *arg)
+{
+ arg = eval_each(arg);
+ return new_pair(head(arg), head(tail(arg)));
+}
+
+static void *base_head(void *arg)
+{
+ arg = eval_each(arg);
+ return head(head(arg));
+}
+
+static void *base_tail(void *arg)
+{
+ arg = eval_each(arg);
+ return tail(head(arg));
+}
+
+static void *base_do(void *arg)
+{
+ void *res = null;
+ arg = eval_each(arg);
+ while (type(arg) == type_pair) {
+ res = head(arg);
+ arg = tail(arg);
}
- va_end(args);
return res;
}
-char *csx_string(const char *string)
+static void *base_is_callable(void *arg)
+{
+ arg = eval_each(arg);
+ return type(head(arg)) == type_fn ||
+ type(head(arg)) == type_base ?
+ one : null;
+}
+
+static void *base_context(void *arg)
+{
+ return context;
+}
+
+static void *base_quote(void *arg)
+{
+ return arg;
+}
+
+static void *base_fn(void *arg)
+{
+ return new_fn(head(arg), tail(arg), context);
+}
+
+static void *base_eval(void *arg);
+static void *base_if(void *arg)
{
- int strsize;
- void *res;
- if (csx_to_init) csx_init();
- strsize = strlen(string) + 1;
- res = type_alloc(type_string, strsize);
- memcpy(res, string, strsize);
+ void *saved = context;
+ void *res = base_eval(head(arg));
+ context = saved;
+ return type(res) != type_null ?
+ base_eval(head(tail(arg))) :
+ base_eval(head(tail(tail(arg))));
+}
+
+
+static void *base_apply(void *arg)
+{ /* shouldn't be called */
+ return null;
+}
+
+static void *setparams(void *params, void *values)
+{
+ void *res = null;
+ while (type(params) == type_pair) {
+ res = new_pair(new_pair(head(params), head(values)), res);
+ params = tail(params);
+ values = tail(values);
+ }
return res;
}
-char *csx_atom(const char *name)
+static void *base_eval(void *arg) {
+tailcall:
+ if (type(arg) == type_name) return tail(lookup(arg));
+ else if (type(arg) == type_pair) {
+ fn_data *fn = base_eval(head(arg));
+ void *ops = tail(arg);
+applycall:
+ if (type(fn) == type_base) {
+ base_data *base = fn;
+ if (*base == base_eval) {
+ ops = eval_each(ops);
+ arg = head(ops);
+ goto tailcall;
+ } else if (*base == base_apply) {
+ ops = eval_each(ops);
+ fn = head(ops);
+ ops = head(tail(ops));
+ goto applycall;
+ } else {
+ return (*base)(ops);
+ }
+ } else if (type(fn) == type_fn) {
+ void *saved;
+ void *res;
+ ops = eval_each(ops);
+ saved = context;
+ context = new_pair(setparams(fn->params, ops), fn->context);
+ res = base_do(fn->body);
+ context = saved;
+ return res;
+ } else {
+ exit(1);
+ }
+ }
+ return arg;
+}
+
+static void *eval_each(void *l)
{
- int namesize;
- void *res;
- if (csx_to_init) csx_init();
- namesize = strlen(name) + 1;
- res = type_alloc(type_atom, namesize);
- memcpy(res, name, namesize);
+ if (type(l) != type_pair) return null;
+ pair_data *res = new_pair(base_eval(head(l)), null);
+ pair_data **p = (pair_data **)&res->tail;
+ l = tail(l);
+ while (type(l) == type_pair) {
+ void *saved = context;
+ *p = new_pair(base_eval(head(l)), null);
+ p = (pair_data **)&(*p)->tail;
+ context = saved;
+ l = tail(l);
+ }
return res;
}
-static void *lookup(struct deflist *d, char *atom)
+static void new_context()
+{
+ context = new_pair(null, null);
+ base_define(csx_list(new_name("not"), new_base(base_not), 0));
+ base_define(csx_list(new_name("pair?"), new_base(base_is_pair), 0));
+ base_define(csx_list(new_name("name?"), new_base(base_is_name), 0));
+ base_define(csx_list(new_name("num?"), new_base(base_is_num), 0));
+ base_define(csx_list(new_name("fn?"), new_base(base_is_callable), 0));
+ base_define(csx_list(new_name("sum"), new_base(base_sum), 0));
+ base_define(csx_list(new_name("diff"), new_base(base_diff), 0));
+ base_define(csx_list(new_name("prod"), new_base(base_prod), 0));
+ base_define(csx_list(new_name("div"), new_base(base_div), 0));
+ base_define(csx_list(new_name("mod"), new_base(base_mod), 0));
+ base_define(csx_list(new_name("eq"), new_base(base_eq), 0));
+ base_define(csx_list(new_name("inc"), new_base(base_inc), 0));
+ base_define(csx_list(new_name("dec"), new_base(base_dec), 0));
+ base_define(csx_list(new_name("pair"), new_base(base_pair), 0));
+ base_define(csx_list(new_name("head"), new_base(base_head), 0));
+ base_define(csx_list(new_name("tail"), new_base(base_tail), 0));
+ base_define(csx_list(new_name("id"), new_base(base_id), 0));
+ base_define(csx_list(new_name("do"), new_base(base_do), 0));
+ base_define(csx_list(new_name("apply"), new_base(base_apply), 0));
+ base_define(csx_list(new_name("context"), new_base(base_context), 0));
+ base_define(csx_list(new_name("eval"), new_base(base_eval), 0));
+ base_define(csx_list(new_name("quote"), new_base(base_quote), 0));
+ base_define(csx_list(new_name("define"), new_base(base_define), 0));
+ base_define(csx_list(new_name("fn"), new_base(base_fn), 0));
+ base_define(csx_list(new_name("if"), new_base(base_if), 0));
+}
+
+
+static void init()
+{
+ initiated = 1;
+ null = new_null();
+ one = new_num(1);
+ new_context();
+}
+
+
+void *csx_list(void *head, ...)
{
- if (!d) return nil;
- if (!strcmp(d->atom, atom)) return d->data;
- return lookup(d->next, atom);
+ va_list args;
+ pair_data *res;
+ pair_data **p;
+ if (!initiated) init();
+ if (!head) return null;
+ res = new_pair(head, null);
+ p = (pair_data **)&res->tail;
+ va_start(args, head);
+ for (head = va_arg(args, void *); head; head = va_arg(args, void *)) {
+ *p = new_pair(head, null);
+ p = (pair_data **)&(*p)->tail;
+ }
+ va_end(args);
+ return res;
}
-void *eval_fn(void *fn, void *args)
-{ /* TODO! */
- /* function : type :> userdata */
- return 0;
+int *csx_num(int num)
+{
+ return new_num(num);
+}
+
+void *csx_eval(void *expression)
+{
+ return base_eval(expression);
}
-static void *eval_pair(struct csx_pair *pair)
+void *csx_base(csx_base_data base)
{
- void *fn;
- int t = *type(pair->car);
- if (t == type_fn) fn = pair->car;
- else fn = csx_evaluate(pair->car);
- return eval_fn(fn, pair->cdr);
+ return new_base(base);
}
-void *csx_evaluate(void *expression)
+char *csx_name(const char *name)
{
- int t = *type(expression);
- if (t == type_atom) return lookup(csx.atoms, expression);
- if (t != type_pair) return nil;
- return eval_pair(expression);
+ return new_name(name);
}