aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorAleksey Veresov <aleksey@veresov.pro>2021-03-27 00:10:49 +0300
committerAleksey Veresov <aleksey@veresov.pro>2021-03-27 00:10:49 +0300
commit32c02216ce3df45004a933cc16745880841262e5 (patch)
tree6ac8a6de24b84d1ffe37195ee0de5313ba1e176c /src
parentea1cd66193d64bb1cd56c24f0db011eadbf558e6 (diff)
downloadcsx-32c02216ce3df45004a933cc16745880841262e5.tar
csx-32c02216ce3df45004a933cc16745880841262e5.tar.xz
csx-32c02216ce3df45004a933cc16745880841262e5.zip
Attempt to make types more generic.
Thing doesn't work now.
Diffstat (limited to 'src')
-rw-r--r--src/csx.c889
-rw-r--r--src/csxbind.c143
2 files changed, 583 insertions, 449 deletions
diff --git a/src/csx.c b/src/csx.c
index 440d732..caf6288 100644
--- a/src/csx.c
+++ b/src/csx.c
@@ -6,139 +6,104 @@
#include <stdio.h>
-static void init();
-
-
-typedef enum csx_type {
- type_null,
- type_pair,
- type_name,
- type_base,
- type_int,
- type_real,
- type_fn,
- type_sx,
- type_str
-} csx_type;
-
-static void setmark(void *p) { ((int *)p)[-2] = 1; }
-static int mark(void *p) { return ((int *)p)[-2]; }
-static csx_type type(void *p) { return ((int *)p)[-1]; }
-
-static void **objs = 0;
-static int objslen = 0;
-static int objssize;
-
-static void pushobj(void *p)
-{
- if (!objs) {
- objs = malloc(sizeof(void *));
- objslen = 0;
- objssize = 1;
- }
- if (objslen == objssize) {
- objs = realloc(objs, (objssize *= 2) * sizeof(void *));
- }
- objs[objslen++] = p;
-}
+typedef struct fn_data {
+ csxpair *params;
+ csxpair *body;
+ csxpair *context;
+} fn_data;
+
-static void **stack = 0;
-static int stacklen = 0;
-static int stacksize;
+csxobj *csx_obj(void *p) { return (csxobj *)((int *)p - 2); }
-static void push(void *p)
+
+static void pushobj(csxi *csx, void *p)
{
- if (!stack) {
- stack = malloc(sizeof(void *));
- stacklen = 0;
- stacksize = 1;
+ if (!csx->objs) {
+ csx->objs = malloc(sizeof(void *));
+ csx->objslen = 0;
+ csx->objssize = 1;
}
- if (stacklen == stacksize) {
- stack = realloc(stack, (stacksize *= 2) * sizeof(void *));
+ if (csx->objslen == csx->objssize) {
+ csx->objssize *= 2;
+ csx->objs = realloc(csx->objs, csx->objssize * sizeof(void *));
}
- stack[stacklen++] = p;
+ csx->objs[csx->objslen++] = p;
}
-static void *pop()
+static void push(csxi *csx, void *p)
{
- return stack[--stacklen];
+ if (!csx->stack) {
+ csx->stack = malloc(sizeof(void *));
+ csx->stacklen = 0;
+ csx->stacksize = 1;
+ }
+ if (csx->stacklen == csx->stacksize) {
+ csx->stacksize *= 2;
+ csx->stack = realloc(csx->stack, csx->stacksize * sizeof(void *));
+ }
+ csx->stack[csx->stacklen++] = p;
}
-static void restore(int len)
+static void *pop(csxi *csx) { return csx->stack[--(csx->stacklen)]; }
+
+static void restore(csxi *csx, int len)
{
- stacklen = len;
- if (stacklen <= stacksize / 4) {
- stacksize /= 2;
- stack = realloc(stack, stacksize * sizeof(void *));
+ csx->stacklen = len;
+ if (csx->stacklen <= csx->stacksize / 4) {
+ csx->stacksize /= 2;
+ csx->stack = realloc(csx->stack, csx->stacksize * sizeof(void *));
}
}
-static void *new(csx_type type, int data_size)
+static void *new(csxi *csx, void *type, int data_size)
{
- int *res = malloc(sizeof(int) * 2 + data_size);
+ csxobj *res = malloc(sizeof(*res) - 1 + data_size);
if (!res) exit(1);
- res[0] = 0;
- res[1] = type;
- pushobj(res);
- return res + 2;
+ res->mark = 0;
+ res->type = type;
+ pushobj(csx, res);
+ return res->data;
}
-typedef struct pair_data {
- void *head;
- void *tail;
-} pair_data;
+static void *head(csxpair *pair) { return pair->head; }
+static void *tail(csxpair *pair) { return pair->tail; }
-static void *head(pair_data *pair) { return pair->head; }
-static void *tail(pair_data *pair) { return pair->tail; }
-
-static pair_data *new_pair(void *head, void *tail)
+csxpair *csx_pair(csxi *csx, void *head, void *tail)
{
- pair_data *res = new(type_pair, sizeof(pair_data));
+ csxpair *res = new(csx, csx->basenames.pair, sizeof(*res));
res->head = head;
res->tail = tail;
return res;
}
-typedef struct fn_data {
- pair_data *params;
- pair_data *body;
- pair_data *context;
-} fn_data;
-
-
-static int initiated = 0;
-static void *null;
-static void *one;
-static pair_data *context;
-
-
-static void deepmark(void *p)
+static void deepmark(csxi *csx, void *p)
{
- if (mark(p)) return;
- setmark(p);
- if (type(p) == type_pair) {
- deepmark(head(p));
- deepmark(tail(p));
- } else if (type(p) == type_fn || type(p) == type_sx) {
+ if (csx_obj(p)->mark) return;
+ csx_obj(p)->mark = 1;
+ if (csx_obj(p)->type == csx->basenames.pair) {
+ deepmark(csx, head(p));
+ deepmark(csx, tail(p));
+ } else if (csx_obj(p)->type == csx->basenames.fn ||
+ csx_obj(p)->type == csx->basenames.sx) {
fn_data *fn = p;
- deepmark(fn->params);
- deepmark(fn->body);
- deepmark(fn->context);
+ deepmark(csx, fn->params);
+ deepmark(csx, fn->body);
+ deepmark(csx, fn->context);
}
}
-static void sweep()
+static void sweep(csxi *csx)
{
- void **old = objs;
- int len = objslen;
+ void **old = csx->objs;
+ int len = csx->objslen;
int i;
- objs = 0;
+ csx->objs = 0;
for (i = 0; i != len; ++i) {
if (*(int *)(old[i])) {
*(int *)(old[i]) = 0;
- pushobj(old[i]);
+ pushobj(csx, old[i]);
} else {
free(old[i]);
}
@@ -146,607 +111,633 @@ static void sweep()
free(old);
}
-static void gc()
+static void gc(csxi *csx)
{
int i;
- static int lastlen = 0;
- if (objslen < lastlen * 2) return;
- setmark(null);
- setmark(one);
- deepmark(context);
- for (i = 0; i != stacklen; ++i) {
- deepmark(stack[i]);
+ if (csx->objslen < csx->lastlen * 2) return;
+ csx_obj(csx->basenames.name)->mark = 1;
+ csx_obj(csx->basenames.pair)->mark = 1;
+ deepmark(csx, csx->context);
+ for (i = 0; i != csx->stacklen; ++i) {
+ deepmark(csx, csx->stack[i]);
}
- sweep();
- lastlen = objslen;
+ sweep(csx);
+ csx->lastlen = csx->objslen;
}
-char *csx_name(const char *name)
+char *csx_name(csxi *csx, const char *name)
{
- if (!initiated) init();
- int namesize = strlen(name) + 1;
+ const int namesize = strlen(name) + 1;
int i;
- for (i = 0; i != objslen; ++i) {
- void *obj = (int *)(objs[i]) + 2;
- if (type(obj) != type_name) continue;
+ for (i = 0; i != csx->objslen; ++i) {
+ void *obj = (int *)(csx->objs[i]) + 2;
+ if (csx_obj(obj)->type != csx->basenames.name) continue;
if (!strncmp(obj, name, namesize)) return obj;
}
- void *res = new(type_name, namesize);
+ void *res = new(csx, csx->basenames.name, namesize);
memcpy(res, name, namesize);
return res;
}
-csx_base_data *csx_base(csx_base_data base)
+csxbase *csx_base(csxi *csx, csxbase base)
{
- if (!initiated) init();
- csx_base_data *res = new(type_base, sizeof(csx_base_data));
+ csxbase *res = new(csx, csx->basenames.base, sizeof(*res));
*res = base;
return res;
}
-int *csx_int(int num)
-{
- if (!initiated) init();
- int *res = new(type_int, sizeof(int));
- *res = num;
- return res;
-}
-
-double *csx_real(double num)
+int *csx_int(csxi *csx, int num)
{
- if (!initiated) init();
- double *res = new(type_real, sizeof(double));
+ int *res = new(csx, csx->basenames._int, sizeof(*res));
*res = num;
return res;
}
-static void *run_each(void *l)
+static void *run_each(csxi *i, void *l)
{
- if (type(l) != type_pair) return null;
- push(l);
- int ret = stacklen;
- pair_data *res = new_pair(csx_run(head(l)), null);
- pair_data **p = (pair_data **)&res->tail;
+ if (csx_obj(l)->type != i->basenames.pair) return i->null;
+ push(i, l);
+ int ret = i->stacklen;
+ csxpair *res = csx_pair(i, csx_run(i, head(l)), i->null);
+ csxpair **p = (csxpair **)&res->tail;
l = tail(l);
- while (type(l) == type_pair) {
- push(res);
- int resret = stacklen;
- *p = new_pair(csx_run(head(l)), null);
- p = (pair_data **)&(*p)->tail;
- restore(resret);
- pop();
+ while (csx_obj(l)->type == i->basenames.pair) {
+ push(i, res);
+ int resret = i->stacklen;
+ *p = csx_pair(i, csx_run(i, head(l)), i->null);
+ p = (csxpair **)&(*p)->tail;
+ restore(i, resret);
+ pop(i);
l = tail(l);
}
- restore(ret);
- pop();
+ restore(i, ret);
+ pop(i);
return res;
}
-static void *lookup_frame(const char *name)
+static void *lookup_frame(csxi *i, const char *name)
{
- pair_data *frame = context->head;
- while (type(frame) == type_pair) {
+ csxpair *frame = i->context->head;
+ while (csx_obj(frame)->type == i->basenames.pair) {
if (head(frame->head) == name) return frame->head;
frame = frame->tail;
}
- return null;
+ return i->null;
}
-static void *lookup(const char *name)
+static void *lookup(csxi *i, const char *name)
{
- void *saved = context;
- while (type(context) == type_pair) {
- pair_data *res = lookup_frame(name);
- if (type(res) != type_null) {
- context = saved;
+ void *saved = i->context;
+ while (csx_obj(i->context)->type == i->basenames.pair) {
+ csxpair *res = lookup_frame(i, name);
+ if (res != i->null) {
+ i->context = saved;
return res->tail;
}
- context = context->tail;
+ i->context = i->context->tail;
}
- context = saved;
- return null;
+ i->context = saved;
+ return i->null;
}
-static void *base_set(void *arg)
+static void *base_set(csxi *i, void *arg)
{
- pair_data *res;
- push(arg);
- int ret = stacklen;
+ csxpair *res;
+ push(i, arg);
+ int ret = i->stacklen;
void *name = head(arg);
- void *value = csx_run(head(tail(arg)));
- if (type(context) == type_null) {
- void *nameval = new_pair(name, value);
- context = new_pair(new_pair(nameval, null), null);
- restore(ret);
- pop();
- return null;
+ void *value = csx_run(i, head(tail(arg)));
+ if (i->context == i->null) {
+ void *nameval = csx_pair(i, name, value);
+ i->context = csx_pair(i, csx_pair(i, nameval, i->null), i->null);
+ restore(i, ret);
+ pop(i);
+ return i->null;
}
- res = lookup_frame(name);
- if (type(res) != type_null) {
+ res = lookup_frame(i, name);
+ if (res != i->null) {
res->tail = value;
} else {
- void **names = &context->head;
- *names = new_pair(new_pair(name, value), *names);
+ void **names = &i->context->head;
+ *names = csx_pair(i, csx_pair(i, name, value), *names);
}
- restore(ret);
- pop();
- return null;
+ restore(i, ret);
+ pop(i);
+ return i->null;
}
-static void *base_is_set(void *arg)
+static void *base_is_set(csxi *i, void *arg)
{
- arg = run_each(arg);
- return lookup(head(arg)) ? one : null;
+ arg = run_each(i, arg);
+ return lookup(i, head(arg)) ? i->one : i->null;
}
-static void *base_sethead(void *arg)
+static void *base_sethead(csxi *i, void *arg)
{
- arg = run_each(arg);
- pair_data *p = head(arg);
+ arg = run_each(i, arg);
+ csxpair *p = head(arg);
p->head = head(tail(arg));
- return null;
+ return i->null;
}
-static void *base_settail(void *arg)
+static void *base_settail(csxi *i, void *arg)
{
- arg = run_each(arg);
- pair_data *p = head(arg);
+ arg = run_each(i, arg);
+ csxpair *p = head(arg);
p->tail = head(tail(arg));
- return null;
+ return i->null;
}
-static void *base_pair(void *arg)
+static void *base_pair(csxi *i, void *arg)
{
- arg = run_each(arg);
- return new_pair(head(arg), head(tail(arg)));
+ arg = run_each(i, arg);
+ return csx_pair(i, head(arg), head(tail(arg)));
}
-static void *base_head(void *arg)
+static void *base_head(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
return head(head(arg));
}
-static void *base_tail(void *arg)
+static void *base_tail(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
return tail(head(arg));
}
-static void *base_quote(void *arg)
+static void *base_qt(csxi *i, void *arg)
{
return head(arg);
}
-static void *base_same(void *arg)
+static void *base_same(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(head(arg)) == type_int)
- return *(int *)head(arg) == *(int *)head(tail(arg)) ? one : null;
- if (type(head(arg)) == type_real)
- return *(double *)head(arg) == *(double *)head(tail(arg)) ? one : null;
- return head(arg) == head(tail(arg)) ? one : null;
+ arg = run_each(i, arg);
+ if (csx_obj(head(arg))->type == i->basenames._int)
+ return *(int *)head(arg) == *(int *)head(tail(arg)) ? i->one : i->null;
+ return head(arg) == head(tail(arg)) ? i->one : i->null;
}
-static void *base_type(void *arg)
+static void *base_type(csxi *i, void *arg)
{
- arg = run_each(arg);
- switch (type(head(arg))) {
- case type_null: return null;
- case type_pair: return csx_name("pair");
- case type_name: return csx_name("name");
- case type_base: return csx_name("base");
- case type_int: return csx_name("int");
- case type_real: return csx_name("real");
- case type_fn: return csx_name("fn");
- case type_sx: return csx_name("sx");
- case type_str: return csx_name("str");
- }
- return 0;
+ arg = run_each(i, arg);
+ return csx_obj(head(arg))->type;
}
-static void *base_do(void *arg)
+static void *base_do(csxi *i, void *arg)
{
- void *res = null;
- arg = run_each(arg);
- while (type(arg) == type_pair) {
+ void *res = i->null;
+ arg = run_each(i, arg);
+ while (csx_obj(arg)->type == i->basenames.pair) {
res = head(arg);
arg = tail(arg);
}
return res;
}
-static void *base_fn(void *arg)
+static void *base_fn(csxi *i, void *arg)
{
- fn_data *res = new(type_fn, sizeof(fn_data));
+ fn_data *res = new(i, i->basenames.fn, sizeof(*res));
res->params = head(arg);
res->body = tail(arg);
- res->context = context;
+ res->context = i->context;
return res;
}
-static void *base_sx(void *arg)
+static void *base_sx(csxi *i, void *arg)
{
- fn_data *res = new(type_sx, sizeof(fn_data));
+ fn_data *res = new(i, i->basenames.sx, sizeof(*res));
res->params = head(arg);
res->body = tail(arg);
- res->context = context;
+ res->context = i->context;
return res;
}
-static void *base_if(void *arg)
+static void *base_if(csxi *i, void *arg)
{
- if (type(arg) != type_pair) return null;
- if (type(tail(arg)) != type_pair) return csx_run(head(arg));
- return type(csx_run(head(arg))) != type_null ?
- csx_run(head(tail(arg))) :
- base_if(tail(tail(arg)));
+ if (csx_obj(arg)->type != i->basenames.pair) return i->null;
+ if (tail(arg) == i->null) return csx_run(i, head(arg));
+ return csx_run(i, head(arg)) != i->null ?
+ csx_run(i, head(tail(arg))) :
+ base_if(i, tail(tail(arg)));
}
-static void *base_sum(void *arg)
+static void *base_sum(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
int res = 0;
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
int *num = head(arg);
- if (type(num) != type_int) exit(1);
+ if (csx_obj(num)->type != i->basenames._int) exit(1);
res += *num;
arg = tail(arg);
}
- return csx_int(res);
+ return csx_int(i, res);
}
-static void *base_prod(void *arg)
+static void *base_prod(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
int res = 1;
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
int *num = head(arg);
- if (type(num) != type_int) exit(1);
+ if (csx_obj(num)->type != i->basenames._int) exit(1);
res *= *num;
arg = tail(arg);
}
- return csx_int(res);
+ return csx_int(i, res);
}
-static void *base_neg(void *arg)
+static void *base_neg(csxi *i, void *arg)
{
- arg = run_each(arg);
- return csx_int(-*(int *)head(arg));
+ arg = run_each(i, arg);
+ return csx_int(i, -*(int *)head(arg));
}
-static void *base_inv(void *arg)
-{ /* todo */
- arg = run_each(arg);
- return csx_int(0);
-}
-
-static void *base_div(void *arg)
+static void *base_div(csxi *i, void *arg)
{
- arg = run_each(arg);
- return csx_int(*(int *)head(arg) / *(int *)head(tail(arg)));
+ arg = run_each(i, arg);
+ return csx_int(i, *(int *)head(arg) / *(int *)head(tail(arg)));
}
-static void *base_mod(void *arg)
+static void *base_mod(csxi *i, void *arg)
{
- arg = run_each(arg);
- return csx_int(*(int *)head(arg) % *(int *)head(tail(arg)));
+ arg = run_each(i, arg);
+ return csx_int(i, *(int *)head(arg) % *(int *)head(tail(arg)));
}
-static void *base_inc(void *arg)
+static void *base_inc(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(arg) != type_pair || type(head(arg)) != type_int) return null;
+ arg = run_each(i, arg);
+ if (csx_obj(arg)->type != i->basenames.pair ||
+ csx_obj(head(arg))->type != i->basenames._int) return i->null;
int num = *(int *)head(arg);
arg = tail(arg);
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
int *another = head(arg);
- if (type(another) != type_int || *another <= num) return null;
+ if (csx_obj(another)->type != i->basenames._int || *another <= num)
+ return i->null;
num = *another;
arg = tail(arg);
}
- return one;
+ return i->one;
}
-static void *base_dec(void *arg)
+static void *base_dec(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(arg) != type_pair || type(head(arg)) != type_int) return null;
+ arg = run_each(i, arg);
+ if (csx_obj(arg)->type != i->basenames.pair ||
+ csx_obj(head(arg))->type != i->basenames._int) return i->null;
int num = *(int *)head(arg);
arg = tail(arg);
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
int *another = head(arg);
- if (type(another) != type_int || *another >= num) return null;
+ if (csx_obj(another)->type != i->basenames._int || *another >= num)
+ return i->null;
num = *another;
arg = tail(arg);
}
- return one;
+ return i->one;
}
-static void *base_out(void *arg)
+static void *base_out(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
int res = putchar(*(int *)head(arg));
- return res != EOF ? one : null;
+ return res != EOF ? i->one : i->null;
}
-static void *base_in(void *arg)
+static void *base_in(csxi *i, void *arg)
{
- arg = run_each(arg);
+ arg = run_each(i, arg);
int res = getchar();
- return res != EOF ? csx_int(res) : null;
+ return res != EOF ? csx_int(i, res) : i->null;
}
-static void *base_name(void *arg)
+static void *base_name(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(head(arg)) != type_str) exit(1);
- return csx_name(head(arg));
+ arg = run_each(i, arg);
+ if (csx_obj(head(arg))->type != i->basenames.str) exit(1);
+ return csx_name(i, head(arg));
}
-static void *base_str(void *arg)
+static void *base_str(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(head(arg)) == type_name) return csx_str(head(arg));
- if (type(head(arg)) == type_null) return csx_str("");
- if (type(head(arg)) != type_pair) exit(1);
+ arg = run_each(i, arg);
+ void *t = csx_obj(head(arg))->type;
+ if (t == i->basenames.name) return csx_str(i, head(arg));
+ if (t == i->null) return csx_str(i, "");
+ if (t != i->basenames.pair) exit(1);
int reslen = 0;
char *res = malloc(1);
arg = head(arg);
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
res[reslen] = *(char *)head(arg);
res = realloc(res, ++reslen + 1);
arg = tail(arg);
}
res[reslen] = 0;
- return csx_str(res);
+ return csx_str(i, res);
}
-static void *base_len(void *arg)
+static void *base_len(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(head(arg)) == type_str) return csx_int(strlen(head(arg)));
- if (type(head(arg)) != type_pair) exit(1);
+ arg = run_each(i, arg);
+ void *t = csx_obj(head(arg))->type;
+ if (t == i->basenames.str) return csx_int(i, strlen(head(arg)));
+ if (t != i->basenames.pair) exit(1);
int len = 0;
arg = head(arg);
- while (type(arg) == type_pair) {
+ while (csx_obj(arg)->type == i->basenames.pair) {
arg = tail(arg);
++len;
}
- return csx_int(len);
+ return csx_int(i, len);
}
-static void *base_run(void *arg)
+static void *base_run(csxi *i, void *arg)
{
- arg = run_each(arg);
- if (type(tail(arg)) == type_null) return csx_run(head(arg));
- push(context);
- int ret = stacklen;
- context = head(tail(arg));
- void *res = csx_run(head(arg));
- void *rescontext = context;
- restore(ret);
- context = pop();
- return new_pair(res, rescontext);
+ arg = run_each(i, arg);
+ if (tail(arg) == i->null) return csx_run(i, head(arg));
+ push(i, i->context);
+ int ret = i->stacklen;
+ i->context = head(tail(arg));
+ void *res = csx_run(i, head(arg));
+ void *rescontext = i->context;
+ restore(i, ret);
+ i->context = pop(i);
+ return csx_pair(i, res, rescontext);
}
-static void *zip(void *params, void *values)
+static void *zip(csxi *i, void *params, void *values)
{
- void *res = null;
- while (type(params) == type_pair) {
- res = new_pair(new_pair(head(params), head(values)), res);
+ void *res = i->null;
+ while (csx_obj(params)->type == i->basenames.pair) {
+ res = csx_pair(i, csx_pair(i, head(params), head(values)), res);
params = tail(params);
values = tail(values);
}
- if (type(params) == type_name)
- res = new_pair(new_pair(params, values), res);
+ if (csx_obj(params)->type == i->basenames.name)
+ res = csx_pair(i, csx_pair(i, params, values), res);
return res;
}
-void *csx_run(void *arg)
+void *csx_run(csxi *i, void *arg)
{
- if (!initiated) init();
- push(arg);
- int ret = stacklen;
+ push(i, arg);
+ int ret = i->stacklen;
tailcall:
- gc();
- if (type(arg) == type_name) {
- restore(ret);
- pop();
- return lookup(arg);
- } else if (type(arg) == type_pair) {
- fn_data *fn = csx_run(head(arg));
+ gc(i);
+ if (csx_obj(arg)->type == i->basenames.name) {
+ restore(i, ret);
+ pop(i);
+ return lookup(i, arg);
+ } else if (csx_obj(arg)->type == i->basenames.pair) {
+ fn_data *fn = csx_run(i, head(arg));
void *ops = tail(arg);
- push(fn);
- if (type(fn) == type_base) {
- csx_base_data *base = (void *)fn;
+ push(i, fn);
+ if (csx_obj(fn)->type == i->basenames.base) {
+ csxbase *base = (void *)fn;
if (*base == csx_run) {
- ops = run_each(ops);
+ ops = run_each(i, ops);
arg = head(ops);
- push(arg);
+ push(i, arg);
goto tailcall;
} else {
- void *res = (*base)(ops);
- restore(ret);
- pop();
+ void *res = (*base)(i, ops);
+ restore(i, ret);
+ pop(i);
return res;
}
- } else if (type(fn) == type_fn) {
+ } else if (csx_obj(fn)->type == i->basenames.fn) {
void *res;
- push(context);
- int fnret = stacklen;
- ops = run_each(ops);
- context = new_pair(zip(fn->params, ops), fn->context);
- res = base_do(fn->body);
- restore(fnret);
- context = pop();
- restore(ret);
- pop();
+ push(i, i->context);
+ int fnret = i->stacklen;
+ ops = run_each(i, ops);
+ i->context = csx_pair(i, zip(i, fn->params, ops), fn->context);
+ res = base_do(i, fn->body);
+ restore(i, fnret);
+ i->context = pop(i);
+ restore(i, ret);
+ pop(i);
return res;
- } else if (type(fn) == type_sx) {
- push(context);
- int sxret = stacklen;
- context = new_pair(zip(fn->params, ops), fn->context);
- arg = base_do(fn->body);
- restore(sxret);
- context = pop();
+ } else if (csx_obj(fn)->type == i->basenames.sx) {
+ push(i, i->context);
+ int sxret = i->stacklen;
+ i->context = csx_pair(i, zip(i, fn->params, ops), fn->context);
+ arg = base_do(i, fn->body);
+ restore(i, sxret);
+ i->context = pop(i);
goto tailcall;
- } else if (type(fn) == type_pair) {
- pair_data *res = (void *)fn;
- int pos = *(int *)csx_run(head(ops));
+ } else if (csx_obj(fn)->type == i->basenames.pair) {
+ csxpair *res = (void *)fn;
+ int pos = *(int *)csx_run(i, head(ops));
while (pos--) res = res->tail;
- restore(ret);
- pop();
+ restore(i, ret);
+ pop(i);
return res->head;
- } else if (type(fn) == type_str) {
+ } else if (csx_obj(fn)->type == i->basenames.str) {
char *res = (void *)fn;
- int pos = *(int *)csx_run(head(ops));
- restore(ret);
- pop();
- return csx_int(res[pos]);
- } else if (type(fn) == type_null) {
- restore(ret);
- pop();
- return null;
+ int pos = *(int *)csx_run(i, head(ops));
+ restore(i, ret);
+ pop(i);
+ return csx_int(i, res[pos]);
+ } else if (csx_obj(fn)->type == i->null) {
+ restore(i, ret);
+ pop(i);
+ return i->null;
} else {
exit(1);
}
}
- restore(ret);
- pop();
+ restore(i, ret);
+ pop(i);
return arg;
}
-static void *base_context(void *args)
-{
- return context;
-}
+static void *base_context(csxi *i, void *args) { return i->context; }
-static void new_context();
-static void *base_newcontext(void *args)
+static void new_context(csxi *i);
+static void *base_newcontext(csxi *i, void *args)
{
- push(context);
- new_context();
- void *res = context;
- context = pop();
+ push(i, i->context);
+ new_context(i);
+ void *res = i->context;
+ i->context = pop(i);
return res;
}
-static void *base_exit(void *args)
+static void *base_exit(csxi *i, void *args)
{
- csx_free();
+ csx_free(i);
exit(0);
}
-static void new_context()
-{
- context = new_pair(null, null);
- base_set(csx_list(csx_name("set"), csx_base(base_set), 0));
- base_set(csx_list(csx_name("set?"), csx_base(base_is_set), 0));
- base_set(csx_list(csx_name("sethead"), csx_base(base_sethead), 0));
- base_set(csx_list(csx_name("settail"), csx_base(base_settail), 0));
- base_set(csx_list(csx_name("pair"), csx_base(base_pair), 0));
- base_set(csx_list(csx_name("head"), csx_base(base_head), 0));
- base_set(csx_list(csx_name("tail"), csx_base(base_tail), 0));
- base_set(csx_list(csx_name("quote"), csx_base(base_quote), 0));
- base_set(csx_list(csx_name("same"), csx_base(base_same), 0));
- base_set(csx_list(csx_name("type"), csx_base(base_type), 0));
- base_set(csx_list(csx_name("do"), csx_base(base_do), 0));
- base_set(csx_list(csx_name("fn"), csx_base(base_fn), 0));
- base_set(csx_list(csx_name("sx"), csx_base(base_sx), 0));
- base_set(csx_list(csx_name("if"), csx_base(base_if), 0));
- base_set(csx_list(csx_name("+"), csx_base(base_sum), 0));
- base_set(csx_list(csx_name("*"), csx_base(base_prod), 0));
- base_set(csx_list(csx_name("neg"), csx_base(base_neg), 0));
- base_set(csx_list(csx_name("inv"), csx_base(base_inv), 0));
- base_set(csx_list(csx_name("div"), csx_base(base_div), 0));
- base_set(csx_list(csx_name("mod"), csx_base(base_mod), 0));
- base_set(csx_list(csx_name("<"), csx_base(base_inc), 0));
- base_set(csx_list(csx_name(">"), csx_base(base_dec), 0));
- base_set(csx_list(csx_name("out"), csx_base(base_out), 0));
- base_set(csx_list(csx_name("in"), csx_base(base_in), 0));
- base_set(csx_list(csx_name("name"), csx_base(base_name), 0));
- base_set(csx_list(csx_name("str"), csx_base(base_str), 0));
- base_set(csx_list(csx_name("len"), csx_base(base_len), 0));
- base_set(csx_list(csx_name("run"), csx_base(base_run), 0));
- base_set(csx_list(csx_name("context"), csx_base(base_context), 0));
- base_set(csx_list(csx_name("newcontext"), csx_base(base_newcontext), 0));
- base_set(csx_list(csx_name("exit"), csx_base(base_exit), 0));
-}
-
-static void init()
-{
- initiated = 1;
- setbuf(stdin, 0);
- setbuf(stdout, 0);
- null = new(type_null, 0);
- one = csx_int(1);
- new_context();
-}
-
-void csx_free()
-{
- initiated = 0;
- while (objslen) {
- free(objs[--objslen]);
+static void new_context(csxi *i)
+{
+ csxbasenames *n = &i->basenames;
+ i->context = csx_pair(i, i->null, i->null);
+ base_set(i, csx_list(i, n->set, csx_base(i, base_set), 0));
+ base_set(i, csx_list(i, n->_isset, csx_base(i, base_is_set), 0));
+ base_set(i, csx_list(i, n->sethead, csx_base(i, base_sethead), 0));
+ base_set(i, csx_list(i, n->settail, csx_base(i, base_settail), 0));
+ base_set(i, csx_list(i, n->pair, csx_base(i, base_pair), 0));
+ base_set(i, csx_list(i, n->head, csx_base(i, base_head), 0));
+ base_set(i, csx_list(i, n->tail, csx_base(i, base_tail), 0));
+ base_set(i, csx_list(i, n->qt, csx_base(i, base_qt), 0));
+ base_set(i, csx_list(i, n->same, csx_base(i, base_same), 0));
+ base_set(i, csx_list(i, n->type, csx_base(i, base_type), 0));
+ base_set(i, csx_list(i, n->_do, csx_base(i, base_do), 0));
+ base_set(i, csx_list(i, n->fn, csx_base(i, base_fn), 0));
+ base_set(i, csx_list(i, n->sx, csx_base(i, base_sx), 0));
+ base_set(i, csx_list(i, n->_if, csx_base(i, base_if), 0));
+ base_set(i, csx_list(i, n->_plus, csx_base(i, base_sum), 0));
+ base_set(i, csx_list(i, n->_star, csx_base(i, base_prod), 0));
+ base_set(i, csx_list(i, n->neg, csx_base(i, base_neg), 0));
+ base_set(i, csx_list(i, n->div, csx_base(i, base_div), 0));
+ base_set(i, csx_list(i, n->mod, csx_base(i, base_mod), 0));
+ base_set(i, csx_list(i, n->_less, csx_base(i, base_inc), 0));
+ base_set(i, csx_list(i, n->_more, csx_base(i, base_dec), 0));
+ base_set(i, csx_list(i, n->out, csx_base(i, base_out), 0));
+ base_set(i, csx_list(i, n->in, csx_base(i, base_in), 0));
+ base_set(i, csx_list(i, n->name, csx_base(i, base_name), 0));
+ base_set(i, csx_list(i, n->str, csx_base(i, base_str), 0));
+ base_set(i, csx_list(i, n->len, csx_base(i, base_len), 0));
+ base_set(i, csx_list(i, n->run, csx_base(i, base_run), 0));
+ base_set(i, csx_list(i, n->context, csx_base(i, base_context), 0));
+ base_set(i, csx_list(i, n->newcontext, csx_base(i, base_newcontext), 0));
+ base_set(i, csx_list(i, n->_exit, csx_base(i, base_exit), 0));
+}
+
+static void init_the_name(csxi *csx)
+{
+ char *name = new(csx, 0, 5);
+ csx_obj(name)->type = name;
+ memcpy(name, "name", 5);
+ csx->basenames.name = name;
+}
+
+static char *init_basename(csxi *csx, const char *name)
+{
+ const int len = strlen(name);
+ char *res = new(csx, csx->basenames.name, len);
+ memcpy(res, name, len);
+ return res;
+}
+
+static void init_basenames(csxi *csx)
+{
+ csxbasenames *n = &csx->basenames;
+ n->pair = init_basename(csx, "pair");
+ n->str = init_basename(csx, "str");
+ n->_int = init_basename(csx, "int");
+ n->base = init_basename(csx, "base");
+ n->fn = init_basename(csx, "fn");
+ n->sx = init_basename(csx, "sx");
+ n->set = init_basename(csx, "set");
+ n->_isset = init_basename(csx, "set?");
+ n->sethead = init_basename(csx, "sethead");
+ n->settail = init_basename(csx, "settail");
+ n->head = init_basename(csx, "head");
+ n->tail = init_basename(csx, "tail");
+ n->qt = init_basename(csx, "qt");
+ n->same = init_basename(csx, "same");
+ n->type = init_basename(csx, "type");
+ n->_do = init_basename(csx, "do");
+ n->_if = init_basename(csx, "if");
+ n->_plus = init_basename(csx, "+");
+ n->_star = init_basename(csx, "*");
+ n->neg = init_basename(csx, "neg");
+ n->div = init_basename(csx, "div");
+ n->mod = init_basename(csx, "mod");
+ n->_less = init_basename(csx, "<");
+ n->_more = init_basename(csx, ">");
+ n->out = init_basename(csx, "out");
+ n->in = init_basename(csx, "in");
+ n->len = init_basename(csx, "len");
+ n->run = init_basename(csx, "run");
+ n->context = init_basename(csx, "context");
+ n->newcontext = init_basename(csx, "newcontext");
+ n->_exit = init_basename(csx, "exit");
+}
+
+
+void csx_init(csxi *csx)
+{
+ csx->objs = 0;
+ csx->objslen = 0;
+ csx->objssize = 0;
+ csx->stack = 0;
+ csx->stacklen = 0;
+ csx->stacksize = 0;
+ csx->lastlen = 0;
+ csx->context = 0;
+ init_the_name(csx);
+ init_basenames(csx);
+ csx->null = new(csx, 0, 0);
+ csx_obj(csx->null)->type = csx->null;
+ csx->one = csx_int(csx, 1);
+ new_context(csx);
+}
+
+void csx_free(csxi *csx)
+{
+ while (csx->objslen) {
+ free(csx->objs[--(csx->objslen)]);
}
- free(objs);
- free(stack);
- objs = 0;
- stack = 0;
+ free(csx->objs);
+ free(csx->stack);
}
-void *csx_list(void *head, ...)
+csxpair *csx_list(csxi *csx, void *head, ...)
{
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;
+ csxpair *res;
+ csxpair **p;
+ if (!head) return csx->null;
+ res = csx_pair(csx, head, csx->null);
+ p = (csxpair **)&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;
+ *p = csx_pair(csx, head, csx->null);
+ p = (csxpair **)&(*p)->tail;
}
va_end(args);
return res;
}
-void *csx_pair(void *a, void *b, void *c, ...)
+csxpair *csx_dot(csxi *csx, void *a, void *b, void *c, ...)
{
va_list args;
- pair_data *res;
- pair_data **p;
- if (!initiated) init();
- if (!c) return new_pair(a, b);
- res = new_pair(a, b);
- p = (pair_data **)&res->tail;
- *p = new_pair(*p, c);
- p = (pair_data **)&(*p)->tail;
+ csxpair *res;
+ csxpair **p;
+ if (!c) return csx_pair(csx, a, b);
+ res = csx_pair(csx, a, b);
+ p = (csxpair **)&res->tail;
+ *p = csx_pair(csx, *p, c);
+ p = (csxpair **)&(*p)->tail;
va_start(args, c);
for (c = va_arg(args, void *); c; c = va_arg(args, void *)) {
- *p = new_pair(*p, c);
- p = (pair_data **)&(*p)->tail;
+ *p = csx_pair(csx, *p, c);
+ p = (csxpair **)&(*p)->tail;
}
va_end(args);
return res;
}
-char *csx_str(const char *str)
+char *csx_str(csxi *csx, const char *str)
{
- if (!initiated) init();
- int strsize = strlen(str) + 1;
- char *res = new(type_str, strsize);
+ const int strsize = strlen(str) + 1;
+ char *res = new(csx, csx->basenames.str, strsize);
memcpy(res, str, strsize);
return res;
}
diff --git a/src/csxbind.c b/src/csxbind.c
new file mode 100644
index 0000000..8e31585
--- /dev/null
+++ b/src/csxbind.c
@@ -0,0 +1,143 @@
+#include "csxbind.h"
+
+#include <stdarg.h>
+
+
+char *name;
+char *pair;
+char *str;
+char *_int;
+char *base;
+char *fn;
+char *sx;
+char *set;
+char *_isset;
+char *sethead;
+char *settail;
+char *head;
+char *tail;
+char *qt;
+char *same;
+char *type;
+char *_do;
+char *_if;
+char *_plus;
+char *_star;
+char *neg;
+char *div;
+char *mod;
+char *_less;
+char *_more;
+char *out;
+char *in;
+char *len;
+char *run;
+char *context;
+char *newcontext;
+char *_exit;
+
+
+static csxi csx;
+static int initialised = 0;
+
+
+void init()
+{
+ initialised = 1;
+ csx_init(&csx);
+ csxbasenames *n = &csx.basenames;
+ name = n->name;
+ pair = n->pair;
+ str = n->str;
+ _int = n->_int;
+ base = n->base;
+ fn = n->fn;
+ sx = n->sx;
+ set = n->set;
+ _isset = n->_isset;
+ sethead = n->sethead;
+ settail = n->settail;
+ head = n->tail;
+ tail = n->tail;
+ qt = n->qt;
+ same = n->same;
+ type = n->type;
+ _do = n->_do;
+ _if = n->_if;
+ _plus = n->_plus;
+ _star = n->_star;
+ neg = n->neg;
+ div = n->div;
+ mod = n->mod;
+ _less = n->_less;
+ _more = n->_more;
+ out = n->out;
+ in = n->in;
+ len = n->len;
+ run = n->run;
+ context = n->context;
+ newcontext = n->newcontext;
+ _exit = n->_exit;
+}
+
+
+csxpair *L(void *head, ...)
+{
+ va_list args;
+ csxpair *res;
+ csxpair **p;
+ if (!head) return csx.null;
+ res = csx_pair(&csx, head, csx.null);
+ p = (csxpair **)&res->tail;
+ va_start(args, head);
+ for (head = va_arg(args, void *); head; head = va_arg(args, void *)) {
+ *p = csx_pair(&csx, head, csx.null);
+ p = (csxpair **)&(*p)->tail;
+ }
+ va_end(args);
+ return res;
+}
+csxpair *D(void *a, void *b, void *c, ...)
+{
+ va_list args;
+ csxpair *res;
+ csxpair **p;
+ if (!c) return csx_pair(&csx, a, b);
+ res = csx_pair(&csx, a, b);
+ p = (csxpair **)&res->tail;
+ *p = csx_pair(&csx, *p, c);
+ p = (csxpair **)&(*p)->tail;
+ va_start(args, c);
+ for (c = va_arg(args, void *); c; c = va_arg(args, void *)) {
+ *p = csx_pair(&csx, *p, c);
+ p = (csxpair **)&(*p)->tail;
+ }
+ va_end(args);
+ return res;
+}
+csxpair *P(void *head, void *tail)
+{
+ return csx_pair(&csx, head, tail);
+}
+char *N(const char *name)
+{
+ return csx_name(&csx, name);
+}
+char *S(const char *str)
+{
+ return csx_str(&csx, str);
+}
+int *I(int num)
+{
+ return csx_int(&csx, num);
+}
+
+void *R(void *expression)
+{
+ return csx_run(&csx, expression);
+}
+
+csxbase *newbase(csxbase base)
+{
+ return csx_base(&csx, base);
+}