.

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;
 }