diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/csx.c | 889 | ||||
| -rw-r--r-- | src/csxbind.c | 143 |
2 files changed, 583 insertions, 449 deletions
@@ -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); +} |