aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/csx.c552
1 files changed, 212 insertions, 340 deletions
diff --git a/src/csx.c b/src/csx.c
index 1a643f2..57b4778 100644
--- a/src/csx.c
+++ b/src/csx.c
@@ -3,7 +3,9 @@
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
-#include <stdio.h>
+
+
+static void init();
typedef enum csx_type {
@@ -11,31 +13,10 @@ typedef enum csx_type {
type_pair,
type_name,
type_base,
- type_num,
+ type_int,
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);
@@ -50,10 +31,13 @@ static void *new(csx_type type, int data_size)
}
-static void *new_null()
-{
- return new(type_null, 0);
-}
+typedef struct pair_data {
+ void *head;
+ void *tail;
+} pair_data;
+
+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)
{
@@ -63,54 +47,82 @@ static pair_data *new_pair(void *head, void *tail)
return res;
}
-static char *new_name(const char *name)
+
+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 pair_data *names;
+static pair_data *ints;
+
+
+char *csx_name(const char *name)
{
+ if (!initiated) init();
int namesize = strlen(name) + 1;
+ pair_data *p = names;
+ while (type(p) == type_pair) {
+ if (!memcmp(p->head, name, namesize)) return p->head;
+ p = p->tail;
+ }
void *res = new(type_name, namesize);
memcpy(res, name, namesize);
+ names = new_pair(res, names);
return res;
}
-static csx_base_data *new_base(csx_base_data base)
+csx_base_data *csx_base(csx_base_data base)
{
+ if (!initiated) init();
csx_base_data *res = new(type_base, sizeof(csx_base_data));
*res = base;
return res;
}
-static int *new_num(int num)
+int *csx_int(int num)
{
- int *res = new(type_num, sizeof(int));
+ if (!initiated) init();
+ pair_data *p = ints;
+ while (type(p) == type_pair) {
+ if (*(int *)p->head == num) return p->head;
+ p = p->tail;
+ }
+ int *res = new(type_int, sizeof(int));
*res = num;
return res;
}
-static fn_data *new_fn(void *params, void *body, void *context)
+
+static void *run_each(void *l)
{
- fn_data *res = new(type_fn, sizeof(fn_data));
- res->params = params;
- res->body = body;
- res->context = context;
+ if (type(l) != type_pair) return null;
+ pair_data *res = new_pair(csx_run(head(l)), null);
+ pair_data **p = (pair_data **)&res->tail;
+ l = tail(l);
+ while (type(l) == type_pair) {
+ void *saved = context;
+ *p = new_pair(csx_run(head(l)), null);
+ p = (pair_data **)&(*p)->tail;
+ context = saved;
+ l = tail(l);
+ }
return res;
}
-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);
+ pair_data *frame = context->head;
while (type(frame) == type_pair) {
- if (!strcmp(head(head(frame)), name)) return head(frame);
- frame = tail(frame);
+ if (!strcmp(head(frame->head), name)) return frame->head;
+ frame = frame->tail;
}
return null;
}
@@ -119,22 +131,22 @@ static void *lookup(const char *name)
{
void *saved = context;
while (type(context) == type_pair) {
- void *res = lookup_frame(name);
+ pair_data *res = lookup_frame(name);
if (type(res) != type_null) {
context = saved;
- return res;
+ return res->tail;
}
- context = tail(context);
+ context = context->tail;
}
context = saved;
- return null;
+ return 0;
}
-static void *base_define(void *arg)
+static void *base_set(void *arg)
{
pair_data *res;
void *name = head(arg);
- void *value = csx_eval(head(tail(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);
@@ -150,172 +162,152 @@ static void *base_define(void *arg)
return null;
}
+static void *base_is_set(void *arg)
+{
+ arg = run_each(arg);
+ return lookup(head(arg)) ? one : null;
+}
-static void *eval_each(void *l);
+static void *base_sethead(void *arg)
+{
+ pair_data *p = head(arg);
+ p->head = head(tail(arg));
+ return null;
+}
+static void *base_settail(void *arg)
+{
+ pair_data *p = head(arg);
+ p->tail = head(tail(arg));
+ return null;
+}
-static void *base_not(void *arg)
+static void *base_pair(void *arg)
{
- arg = eval_each(arg);
- return type(head(arg)) == type_null ? one : null;
+ arg = run_each(arg);
+ return new_pair(head(arg), head(tail(arg)));
}
-static void *base_is_pair(void *arg)
+static void *base_head(void *arg)
{
- arg = eval_each(arg);
- return type(head(arg)) == type_pair ? one : null;
+ arg = run_each(arg);
+ return head(head(arg));
}
-static void *base_is_name(void *arg)
+static void *base_tail(void *arg)
{
- arg = eval_each(arg);
- return type(head(arg)) == type_name ? one : null;
+ arg = run_each(arg);
+ return tail(head(arg));
}
-static void *base_is_num(void *arg)
+static void *base_quote(void *arg)
{
- arg = eval_each(arg);
- return type(head(arg)) == type_num ? one : null;
+ return arg;
}
-static void *base_sum(void *arg)
+static void *base_same(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);
+ arg = run_each(arg);
+ return head(arg) == head(tail(arg)) ? one : null;
}
-static void *base_diff(void *arg)
+static void *base_type(void *arg)
{
- arg = eval_each(arg);
- return new_num(*(int *)head(arg) - *(int *)head(tail(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_fn: return csx_name("fn");
+ }
+ return 0;
}
-static void *base_prod(void *arg)
+static void *base_do(void *arg)
{
- arg = eval_each(arg);
- int res = 1;
+ void *res = null;
+ arg = run_each(arg);
while (type(arg) == type_pair) {
- void *num = head(arg);
- if (type(num) != type_num) exit(1);
- res *= *(int *)num;
+ res = head(arg);
arg = tail(arg);
}
- return new_num(res);
+ return res;
}
-static void *base_div(void *arg)
+static void *base_fn(void *arg)
{
- arg = eval_each(arg);
- return new_num(*(int *)head(arg) / *(int *)head(tail(arg)));
+ fn_data *res = new(type_fn, sizeof(fn_data));
+ res->params = head(arg);
+ res->body = tail(arg);
+ res->context = context;
+ return res;
}
-static void *base_mod(void *arg)
+static void *base_if(void *arg)
{
- arg = eval_each(arg);
- return new_num(*(int *)head(arg) % *(int *)head(tail(arg)));
+ void *saved = context;
+ void *res = csx_run(head(arg));
+ context = saved;
+ return type(res) != type_null ?
+ csx_run(head(tail(arg))) :
+ csx_run(head(tail(tail(arg))));
}
-static void *base_id(void *arg)
-{
- arg = eval_each(arg);
- return arg;
-}
-static void *base_and(void *arg)
+static void *base_sum(void *arg)
{
- arg = eval_each(arg);
+ arg = run_each(arg);
+ int res = 0;
while (type(arg) == type_pair) {
- if (type(head(arg)) == type_null) return null;
+ int *num = head(arg);
+ if (type(num) != type_int) exit(1);
+ res += *num;
arg = tail(arg);
}
- return one;
+ return csx_int(res);
}
-static void *base_or(void *arg)
+static void *base_prod(void *arg)
{
- arg = eval_each(arg);
+ arg = run_each(arg);
+ int res = 1;
while (type(arg) == type_pair) {
- if (type(head(arg)) != type_null) return one;
+ int *num = head(arg);
+ if (type(num) != type_int) exit(1);
+ res *= *num;
arg = tail(arg);
}
- return null;
+ return csx_int(res);
}
-
-static void *base_eq(void *arg);
-
-static void *eqpair(void *a, void *rest)
+static void *base_neg(void *arg)
{
- 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;
+ arg = run_each(arg);
+ return csx_int(-*(int *)head(head(arg)));
}
-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 *base_inv(void *arg)
+{ /* todo */
+ arg = run_each(arg);
+ return csx_int(0);
}
-static void *eqnum(int *a, void *rest)
+static void *base_mod(void *arg)
{
- 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;
+ arg = run_each(arg);
+ return csx_int(*(int *)head(arg) % *(int *)head(tail(arg)));
}
-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;
+ arg = run_each(arg);
+ if (type(arg) != type_pair || type(head(arg)) != type_int) 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;
+ if (type(another) != type_int || *another <= num) return null;
num = *another;
arg = tail(arg);
}
@@ -324,115 +316,21 @@ static void *base_inc(void *arg)
static void *base_dec(void *arg)
{
- arg = eval_each(arg);
- if (type(arg) != type_pair || type(head(arg)) != type_num) return null;
+ arg = run_each(arg);
+ if (type(arg) != type_pair || type(head(arg)) != type_int) 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;
+ if (type(another) != type_int || *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);
- }
- return res;
-}
-
-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 head(arg);
-}
-
-static void *base_input(void *arg)
-{
- int res = getchar();
- return res != EOF ? new_num(res) : null;
-}
-
-static void *base_output(void *arg)
-{
- arg = eval_each(arg);
- return putchar(*(int *)head(arg)) != EOF ? one : null;
-}
-
-static void *base_outname(void *arg)
-{
- arg = eval_each(arg);
- return fputs(head(arg), stdout) != EOF ? one : null;
-}
-
-static void *base_outnum(void *arg)
-{
- arg = eval_each(arg);
- int num = *(int *)head(arg);
- printf("%d", num);
- return one;
-}
-
-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)
-{
- 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)
+static void *zip(void *params, void *values)
{
void *res = null;
while (type(params) == type_pair) {
@@ -443,33 +341,32 @@ static void *setparams(void *params, void *values)
return res;
}
-static void *base_eval(void *arg) {
+void *csx_run(void *arg)
+{
+ if (!initiated) init();
tailcall:
- if (type(arg) == type_name) return tail(lookup(arg));
- else if (type(arg) == type_pair) {
- fn_data *fn = base_eval(head(arg));
+ if (type(arg) == type_name) {
+ void *r = lookup(arg);
+ if (!r) exit(1);
+ return r;
+ } else if (type(arg) == type_pair) {
+ fn_data *fn = csx_run(head(arg));
void *ops = tail(arg);
-applycall:
if (type(fn) == type_base) {
csx_base_data *base = (void *)fn;
- if (*base == base_eval) {
- ops = eval_each(ops);
+ if (*base == csx_run) {
+ ops = run_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);
+ ops = run_each(ops);
saved = context;
- context = new_pair(setparams(fn->params, ops), fn->context);
+ context = new_pair(zip(fn->params, ops), fn->context);
res = base_do(fn->body);
context = saved;
return res;
@@ -480,65 +377,40 @@ applycall:
return arg;
}
-static void *eval_each(void *l)
-{
- 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 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));
- base_define(csx_list(new_name("and"), new_base(base_and), 0));
- base_define(csx_list(new_name("or"), new_base(base_or), 0));
- base_define(csx_list(new_name("input"), new_base(base_input), 0));
- base_define(csx_list(new_name("output"), new_base(base_output), 0));
- base_define(csx_list(new_name("outname"), new_base(base_outname), 0));
- base_define(csx_list(new_name("outnum"), new_base(base_outnum), 0));
+ 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("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("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("run"), csx_base(csx_run), 0));
}
-
static void init()
{
initiated = 1;
- null = new_null();
- one = new_num(1);
+ null = new(type_null, 0);
+ names = null;
+ ints = null;
+ one = csx_int(1);
new_context();
}
@@ -561,22 +433,22 @@ void *csx_list(void *head, ...)
return res;
}
-int *csx_num(int num)
-{
- return new_num(num);
-}
-
-void *csx_eval(void *expression)
-{
- return base_eval(expression);
-}
-
-void *csx_base(csx_base_data base)
+void *csx_dot(void *a, void *b, void *c, ...)
{
- return new_base(base);
-}
-
-char *csx_name(const char *name)
-{
- return new_name(name);
+ 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;
+ 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;
+ }
+ va_end(args);
+ return res;
}