aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE2
-rw-r--r--examples/fib.c50
-rw-r--r--examples/strfib.c53
-rw-r--r--include/csx.h19
-rw-r--r--include/csx/csx.h25
-rw-r--r--src/csx.c604
6 files changed, 569 insertions, 184 deletions
diff --git a/LICENSE b/LICENSE
index 4921ae2..d14c38c 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright 2020 Aleksey Veresov
+Copyright 2020-2021 Aleksey Veresov
This software is provided 'as-is', without any express or implied warranty.
In no event will the authors be held liable for any damages arising from
diff --git a/examples/fib.c b/examples/fib.c
new file mode 100644
index 0000000..0c94673
--- /dev/null
+++ b/examples/fib.c
@@ -0,0 +1,50 @@
+#include <csx.h>
+#include <stdio.h>
+
+
+static csx_list_fn *l;
+static csx_num_fn *n;
+
+char *define;
+char *fn;
+char *pair;
+char *head;
+char *tail;
+char *not;
+char *csx_if;
+char *inc;
+char *sum;
+char *diff;
+
+void process()
+{
+ char *fib = csx_name("fib");
+ char *num = csx_name("num");
+ csx_eval(l(define, fib, l(fn, l(num, 0),
+ l(csx_if, l(inc, num, n(2), 0), n(1),
+ l(sum,
+ l(fib, l(diff, num, n(1), 0), 0),
+ l(fib, l(diff, num, n(2), 0), 0),
+ 0),
+ 0),
+ 0), 0));
+ printf("fib 6 = %d\n", *(int *)csx_eval(l(fib, n(6), 0)));
+}
+
+int main()
+{
+ l = csx_list;
+ n = csx_num;
+ define = csx_name("define");
+ fn = csx_name("fn");
+ pair = csx_name("pair");
+ head = csx_name("head");
+ tail = csx_name("tail");
+ not = csx_name("not");
+ csx_if = csx_name("if");
+ inc = csx_name("inc");
+ sum = csx_name("sum");
+ diff = csx_name("diff");
+ process();
+ return 0;
+}
diff --git a/examples/strfib.c b/examples/strfib.c
deleted file mode 100644
index 6e22c7f..0000000
--- a/examples/strfib.c
+++ /dev/null
@@ -1,53 +0,0 @@
-#include <csx/csx.h>
-#include <stdio.h>
-
-
-static csx_type_function_list *l;
-static csx_type_function_string *s;
-static csx_type_function_atom *a;
-static csx_type_function_evaluate *e;
-
-static char *append;
-static char *define;
-static char *cdr;
-static char *ifx;
-static char *not;
-
-void printfibs(char *strfib)
-{
- const char *input = "oooooooooo" + 9;
- int i;
- for (i = 0; i != 10; ++i)
- puts(e(l(strfib, s(input - i), 0)));
-}
-
-void process()
-{
- char *strfib = a("strfib");
- char *n = a("n");
- e(l(define, l(strfib, n, 0),
- l(ifx, l(not, n, 0), s(""),
- l(ifx, l(not, l(cdr, n, 0), 0), s("o"),
- l(append, l(strfib, l(cdr, n, 0), 0),
- l(strfib, l(cdr, l(cdr, n, 0), 0), 0), 0),
- 0),
- 0),
- 0));
- printfibs(strfib);
-}
-
-int main()
-{
- l = csx_list;
- s = csx_string;
- a = csx_atom;
- e = csx_evaluate;
- append = a("append");
- define = a("define");
- cdr = a("cdr");
- ifx = a("ifx");
- not = a("not");
- process();
- csx_free();
- return 0;
-}
diff --git a/include/csx.h b/include/csx.h
new file mode 100644
index 0000000..90d18c2
--- /dev/null
+++ b/include/csx.h
@@ -0,0 +1,19 @@
+#ifndef CSX_INCLUDED
+#define CSX_INCLUDED
+
+
+typedef void *(csx_list_fn)(void *head, ...);
+void *csx_list(void *head, ...);
+
+typedef int *(csx_num_fn)(int num);
+int *csx_num(int num);
+
+void *csx_eval(void *expression);
+
+typedef void *(csx_base_data)(void *arg);
+void *csx_base(csx_base_data base);
+
+char *csx_name(const char *name);
+
+
+#endif
diff --git a/include/csx/csx.h b/include/csx/csx.h
deleted file mode 100644
index db2d1b3..0000000
--- a/include/csx/csx.h
+++ /dev/null
@@ -1,25 +0,0 @@
-#ifndef CSX_INCLUDED
-#define CSX_INCLUDED
-
-
-struct csx_pair {
- void *car;
- void *cdr;
-};
-
-typedef struct csx_pair *(csx_type_function_list)(void *head, ...);
-struct csx_pair *csx_list(void *head, ...);
-
-typedef char *(csx_type_function_string)(const char *string);
-char *csx_string(const char *string);
-
-typedef char *(csx_type_function_atom)(const char *name);
-char *csx_atom(const char *name);
-
-typedef void *(csx_type_function_evaluate)(void *expression);
-void *csx_evaluate(void *expression);
-
-void csx_free();
-
-
-#endif
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);
}