From 0c32a26c9a43b2d45968b9ac59b8916c1d4092d1 Mon Sep 17 00:00:00 2001
From: Aleksey Veresov <aleksey@veresov.pro>
Date: Sat, 2 Jan 2021 19:24:13 +0300
Subject: .

---
 src/csx.c | 604 +++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 499 insertions(+), 105 deletions(-)

(limited to 'src')

diff --git a/src/csx.c b/src/csx.c
index b6b0d38..abf94aa 100644
--- a/src/csx.c
+++ b/src/csx.c
@@ -5,163 +5,557 @@
 #include <string.h>
 
 
-enum { type_nil, type_pair, type_string, type_atom, type_fn };
-static int  *type(char *p)         { return (int *) (p - sizeof(int)); }
-static void  type_shift(void *p)  { *(char **)p += sizeof(int); }
-static void *type_alloc(int t, int content_size)
-{
-    int *res = malloc(sizeof(int) + content_size);
-    *res     = t;
-    type_shift(&res);
-    return res;
+typedef enum csx_type {
+    type_null,
+    type_pair,
+    type_name,
+    type_base,
+    type_num,
+    type_fn
+} csx_type;
+
+
+/* typedef void null_data; */
+
+typedef struct pair_data {
+    void *head;
+    void *tail;
+} pair_data;
+
+/* typedef char name_data; */
+
+typedef csx_base_data base_data;
+
+/* typedef int num_data; */
+
+typedef struct fn_data {
+    pair_data *params;
+    pair_data *body;
+    pair_data *context;
+} fn_data;
+
+
+static csx_type type(void *p)
+{
+    return *((int *)p - 1);
 }
 
+static void *new(csx_type type, int data_size)
+{
+    int *res = malloc(sizeof(int) + data_size);
+    if (!res) exit(1);
+    *res = type;
+    return res + 1;
+}
 
-struct deflist {
-    char *atom;
-    void *data;
-    struct deflist *next;
-};
 
-static struct state {
-    struct deflist *atoms;
-} csx;
-static int csx_to_init = 0;
+static void *new_null()
+{
+    return new(type_null, 0);
+}
+
+static pair_data *new_pair(void *head, void *tail)
+{
+    pair_data *res = new(type_pair, sizeof(pair_data));
+    res->head = head;
+    res->tail = tail;
+    return res;
+}
 
-static void *nil;
+static char *new_name(const char *name)
+{
+    int namesize = strlen(name) + 1;
+    void *res = new(type_name, namesize);
+    memcpy(res, name, namesize);
+    return res;
+}
 
+static base_data *new_base(base_data base)
+{
+    base_data *res = new(type_base, sizeof(base_data));
+    *res = base;
+    return res;
+}
 
-static void adddef(struct deflist **l, const char *atom, void *data)
+static int *new_num(int num)
 {
-    struct deflist *old = *l;
-    *l = malloc(sizeof(**l));
-    (*l)->next = old;
-    (*l)->atom = scopy(atom);
-    (*l)->data = data;
+    int *res = new(type_num, sizeof(int));
+    *res = num;
+    return res;
 }
 
-static void *csx_fn_new(void *fn, void *userdata, int size)
+static fn_data *new_fn(void *params, void *body, void *context)
 {
-    void *res = malloc(sizeof(fn) + sizeof(int) + size);
-    *(void **)res = fn;
-    (char *)res += sizeof(fn);
-    *(int *)res = type_fn;
-    typeshift(&res);
-    if (userdata && size) memcpy(res, userdata, size);
+    fn_data *res = new(type_fn, sizeof(fn_data));
+    res->params = params;
+    res->body = body;
+    res->context = context;
     return res;
 }
 
-static void *define(void *userdata, struct csx_pair *data)
-{  /* TODO! */
-    int t = *type(data);
-    if (t != type_pair) return nil;
-    t = *type(data->car);
-    if (t == type_atom) {
-        struct csx_pair *cdr = data->cdr;
-        if (*type(cdr) != type_pair || *type(cdr->cdr) != type_nil)
-            return nil;
-        return define_constant(data->car, cdr->cdr);
+
+static void *head(pair_data *pair)  { return pair->head; }
+static void *tail(pair_data *pair)  { return pair->tail; }
+
+
+static int initiated = 0;
+static void *null;
+static void *one;
+static pair_data *context;
+
+
+static void *lookup_frame(const char *name)
+{
+    void *frame = head(context);
+    while (type(frame) == type_pair) {
+        if (!strcmp(head(head(frame)), name)) return head(frame);
+        frame = tail(frame);
+    }
+    return null;
+}
+
+static void *lookup(const char *name)
+{
+    void *saved = context;
+    while (type(context) == type_pair) {
+        void *res = lookup_frame(name);
+        if (type(res) != type_null) {
+            context = saved;
+            return res;
+        }
+        context = tail(context);
+    }
+    context = saved;
+    return null;
+}
+
+static void *base_define(void *arg)
+{
+    pair_data *res;
+    void *name = head(arg);
+    void *value = head(tail(arg));
+    if (type(context) == type_null) {
+        void *nameval = new_pair(name, value);
+        context = new_pair(new_pair(nameval, null), null);
+        return null;
+    }
+    res = lookup_frame(name);
+    if (type(res) != type_null) {
+        res->tail = value;
+    } else {
+        void **names = &context->head;
+        *names = new_pair(new_pair(name, value), *names);
     }
-    return define_function(data->car, data->cdr);
+    return null;
 }
 
-/* TODO append, cdr, ... */
 
-static void csx_init()
+static void *eval_each(void *l);
+
+
+static void *base_not(void *arg)
 {
-    if (!csx_to_init) csx_free();
-    csx.atoms = 0;
+    arg = eval_each(arg);
+    return type(head(arg)) == type_null ? one : null;
+}
 
-    nil = type_alloc(type_nil, 0);
-    adddef(csx.atoms, "append", csx_fn_new(append, 0, 0));
-    adddef(csx.atoms, "define", csx_fn_new(define, 0, 0));
-    adddef(csx.atoms, "cdr",    csx_fn_new(cdr,    0, 0));
-    adddef(csx.atoms, "ifx",    csx_fn_new(ifx,    0, 0));
-    adddef(csx.atoms, "not",    csx_fn_new(not,    0, 0));
+static void *base_is_pair(void *arg)
+{
+    arg = eval_each(arg);
+    return type(head(arg)) == type_pair ? one : null;
 }
 
-void csx_free()
+static void *base_is_name(void *arg)
 {
-    free(nil);
-    /* free everything allocated */
-    csx_to_init = 0;
+    arg = eval_each(arg);
+    return type(head(arg)) == type_name ? one : null;
 }
 
+static void *base_is_base(void *arg)
+{
+    arg = eval_each(arg);
+    return type(head(arg)) == type_base ? one : null;
+}
 
-struct csx_pair *csx_pair_new(void *car, void *cdr)
+static void *base_is_num(void *arg)
 {
-    struct csx_pair *res =type_alloc(type_pair, sizeof(*res));
-    res->car = car;
-    res->cdr = cdr;
-    return res;
+    arg = eval_each(arg);
+    return type(head(arg)) == type_num ? one : null;
+}
+
+static void *base_is_fn(void *arg)
+{
+    arg = eval_each(arg);
+    return type(head(arg)) == type_fn ? one : null;
 }
 
+static void *base_sum(void *arg)
+{
+    arg = eval_each(arg);
+    int res = 0;
+    while (type(arg) == type_pair) {
+        void *num = head(arg);
+        if (type(num) != type_num) exit(1);
+        res += *(int *)num;
+        arg = tail(arg);
+    }
+    return new_num(res);
+}
 
-struct csx_pair *csx_list(void *head, ...)
+static void *base_diff(void *arg)
 {
-    struct csx_pair *res;
-    va_list args;
-    if (csx_to_init) csx_init();
-    if (!head) return nil;
+    arg = eval_each(arg);
+    return new_num(*(int *)head(arg) - *(int *)head(tail(arg)));
+}
 
-    res = csx_pair_new(head, nil);
-    va_start(args, head);
-    for (head = va_arg(args, void *); head; head = va_arg(args, void *)) {
-        res->cdr = csx_pair_new(head, nil);
+static void *base_prod(void *arg)
+{
+    arg = eval_each(arg);
+    int res = 1;
+    while (type(arg) == type_pair) {
+        void *num = head(arg);
+        if (type(num) != type_num) exit(1);
+        res *= *(int *)num;
+        arg = tail(arg);
+    }
+    return new_num(res);
+}
+
+static void *base_div(void *arg)
+{
+    arg = eval_each(arg);
+    return new_num(*(int *)head(arg) / *(int *)head(tail(arg)));
+}
+
+static void *base_mod(void *arg)
+{
+    arg = eval_each(arg);
+    return new_num(*(int *)head(arg) % *(int *)head(tail(arg)));
+}
+
+static void *base_id(void *arg)
+{
+    arg = eval_each(arg);
+    return arg;
+}
+
+static void *base_and(void *arg)
+{
+    arg = eval_each(arg);
+    while (type(arg) == type_pair) {
+        if (type(head(arg)) == type_null) return null;
+        arg = tail(arg);
+    }
+    return one;
+}
+
+static void *base_or(void *arg)
+{
+    arg = eval_each(arg);
+    while (type(arg) == type_pair) {
+        if (type(head(arg)) != type_null) return one;
+        arg = tail(arg);
+    }
+    return null;
+}
+
+
+static void *base_eq(void *arg);
+
+static void *eqpair(void *a, void *rest)
+{
+    while (type(rest) == type_pair) {
+        void *res;
+        void *another = head(rest);
+        if (type(another) != type_pair) return null;
+        res = base_eq(new_pair(head(a), new_pair(head(another), null)));
+        if (type(res) == type_null) return null;
+        res = base_eq(new_pair(tail(a), new_pair(tail(another), null)));
+        if (type(res) == type_null) return null;
+        rest = tail(rest);
+    }
+    return one;
+}
+
+static void *eqname(char *a, void *rest)
+{
+    while (type(rest) == type_pair) {
+        char *another = head(rest);
+        if (type(another) != type_name || strcmp(another, a)) return null;
+        rest = tail(rest);
+    }
+    return one;
+}
+
+static void *eqnum(int *a, void *rest)
+{
+    int num = *a;
+    while (type(rest) == type_pair) {
+        int *another = head(rest);
+        if (type(another) != type_num || *another != num) return null;
+        rest = tail(rest);
+    }
+    return one;
+}
+
+static void *base_eq(void *arg)
+{
+    arg = eval_each(arg);
+    void *a;
+    void *rest;
+    if (type(arg) != type_pair) return null;
+    a = head(arg);
+    rest = tail(arg);
+    if (type(a) == type_pair) return eqpair(a, rest);
+    if (type(a) == type_name) return eqname(a, rest);
+    if (type(a) == type_num) return eqnum(a, rest);
+    while (type(rest) == type_pair) {
+        void *another = head(rest);
+        if (another != a) return null;
+        rest = tail(rest);
+    }
+    return one;
+}
+
+
+static void *base_inc(void *arg)
+{
+    arg = eval_each(arg);
+    if (type(arg) != type_pair || type(head(arg)) != type_num) return null;
+    int num = *(int *)head(arg);
+    arg = tail(arg);
+    while (type(arg) == type_pair) {
+        int *another = head(arg);
+        if (type(another) != type_num || *another <= num) return null;
+        num = *another;
+        arg = tail(arg);
+    }
+    return one;
+}
+
+static void *base_dec(void *arg)
+{
+    arg = eval_each(arg);
+    if (type(arg) != type_pair || type(head(arg)) != type_num) return null;
+    int num = *(int *)head(arg);
+    arg = tail(arg);
+    while (type(arg) == type_pair) {
+        int *another = head(arg);
+        if (type(another) != type_num || *another >= num) return null;
+        num = *another;
+        arg = tail(arg);
+    }
+    return one;
+}
+
+static void *base_pair(void *arg)
+{
+    arg = eval_each(arg);
+    return new_pair(head(arg), head(tail(arg)));
+}
+
+static void *base_head(void *arg)
+{
+    arg = eval_each(arg);
+    return head(head(arg));
+}
+
+static void *base_tail(void *arg)
+{
+    arg = eval_each(arg);
+    return tail(head(arg));
+}
+
+static void *base_do(void *arg)
+{
+    void *res = null;
+    arg = eval_each(arg);
+    while (type(arg) == type_pair) {
+        res = head(arg);
+        arg = tail(arg);
     }
-    va_end(args);
     return res;
 }
 
-char *csx_string(const char *string)
+static void *base_is_callable(void *arg)
+{
+    arg = eval_each(arg);
+    return type(head(arg)) == type_fn ||
+        type(head(arg)) == type_base ?
+        one : null;
+}
+
+static void *base_context(void *arg)
+{
+    return context;
+}
+
+static void *base_quote(void *arg)
+{
+    return arg;
+}
+
+static void *base_fn(void *arg)
+{
+    return new_fn(head(arg), tail(arg), context);
+}
+
+static void *base_eval(void *arg);
+static void *base_if(void *arg)
 {
-    int   strsize;
-    void *res;
-    if (csx_to_init) csx_init();
-    strsize = strlen(string) + 1;
-    res     = type_alloc(type_string, strsize);
-    memcpy(res, string, strsize);
+    void *saved = context;
+    void *res = base_eval(head(arg));
+    context = saved;
+    return type(res) != type_null ?
+        base_eval(head(tail(arg))) :
+        base_eval(head(tail(tail(arg))));
+}
+
+
+static void *base_apply(void *arg)
+{  /* shouldn't be called */
+    return null;
+}
+
+static void *setparams(void *params, void *values)
+{
+    void *res = null;
+    while (type(params) == type_pair) {
+        res = new_pair(new_pair(head(params), head(values)), res);
+        params = tail(params);
+        values = tail(values);
+    }
     return res;
 }
 
-char *csx_atom(const char *name)
+static void *base_eval(void *arg) {
+tailcall:
+    if (type(arg) == type_name) return tail(lookup(arg));
+    else if (type(arg) == type_pair) {
+        fn_data *fn = base_eval(head(arg));
+        void *ops = tail(arg);
+applycall:
+        if (type(fn) == type_base) {
+            base_data *base = fn;
+            if (*base == base_eval) {
+                ops = eval_each(ops);
+                arg = head(ops);
+                goto tailcall;
+            } else if (*base == base_apply) {
+                ops = eval_each(ops);
+                fn = head(ops);
+                ops = head(tail(ops));
+                goto applycall;
+            } else {
+                return (*base)(ops);
+            }
+        } else if (type(fn) == type_fn) {
+            void *saved;
+            void *res;
+            ops = eval_each(ops);
+            saved = context;
+            context = new_pair(setparams(fn->params, ops), fn->context);
+            res = base_do(fn->body);
+            context = saved;
+            return res;
+        } else {
+            exit(1);
+        }
+    }
+    return arg;
+}
+
+static void *eval_each(void *l)
 {
-    int   namesize;
-    void *res;
-    if (csx_to_init) csx_init();
-    namesize = strlen(name) + 1;
-    res      = type_alloc(type_atom, namesize);
-    memcpy(res, name, namesize);
+    if (type(l) != type_pair) return null;
+    pair_data *res = new_pair(base_eval(head(l)), null);
+    pair_data **p = (pair_data **)&res->tail;
+    l = tail(l);
+    while (type(l) == type_pair) {
+        void *saved = context;
+        *p = new_pair(base_eval(head(l)), null);
+        p = (pair_data **)&(*p)->tail;
+        context = saved;
+        l = tail(l);
+    }
     return res;
 }
 
 
-static void *lookup(struct deflist *d, char *atom)
+static void new_context()
+{
+    context = new_pair(null, null);
+    base_define(csx_list(new_name("not"), new_base(base_not), 0));
+    base_define(csx_list(new_name("pair?"), new_base(base_is_pair), 0));
+    base_define(csx_list(new_name("name?"), new_base(base_is_name), 0));
+    base_define(csx_list(new_name("num?"), new_base(base_is_num), 0));
+    base_define(csx_list(new_name("fn?"), new_base(base_is_callable), 0));
+    base_define(csx_list(new_name("sum"), new_base(base_sum), 0));
+    base_define(csx_list(new_name("diff"), new_base(base_diff), 0));
+    base_define(csx_list(new_name("prod"), new_base(base_prod), 0));
+    base_define(csx_list(new_name("div"), new_base(base_div), 0));
+    base_define(csx_list(new_name("mod"), new_base(base_mod), 0));
+    base_define(csx_list(new_name("eq"), new_base(base_eq), 0));
+    base_define(csx_list(new_name("inc"), new_base(base_inc), 0));
+    base_define(csx_list(new_name("dec"), new_base(base_dec), 0));
+    base_define(csx_list(new_name("pair"), new_base(base_pair), 0));
+    base_define(csx_list(new_name("head"), new_base(base_head), 0));
+    base_define(csx_list(new_name("tail"), new_base(base_tail), 0));
+    base_define(csx_list(new_name("id"), new_base(base_id), 0));
+    base_define(csx_list(new_name("do"), new_base(base_do), 0));
+    base_define(csx_list(new_name("apply"), new_base(base_apply), 0));
+    base_define(csx_list(new_name("context"), new_base(base_context), 0));
+    base_define(csx_list(new_name("eval"), new_base(base_eval), 0));
+    base_define(csx_list(new_name("quote"), new_base(base_quote), 0));
+    base_define(csx_list(new_name("define"), new_base(base_define), 0));
+    base_define(csx_list(new_name("fn"), new_base(base_fn), 0));
+    base_define(csx_list(new_name("if"), new_base(base_if), 0));
+}
+
+
+static void init()
+{
+    initiated = 1;
+    null = new_null();
+    one = new_num(1);
+    new_context();
+}
+
+
+void *csx_list(void *head, ...)
 {
-    if (!d) return nil;
-    if (!strcmp(d->atom, atom)) return d->data;
-    return lookup(d->next, atom);
+    va_list args;
+    pair_data *res;
+    pair_data **p;
+    if (!initiated) init();
+    if (!head) return null;
+    res = new_pair(head, null);
+    p = (pair_data **)&res->tail;
+    va_start(args, head);
+    for (head = va_arg(args, void *); head; head = va_arg(args, void *)) {
+        *p = new_pair(head, null);
+        p = (pair_data **)&(*p)->tail;
+    }
+    va_end(args);
+    return res;
 }
 
-void *eval_fn(void *fn, void *args)
-{  /* TODO! */
-    /* function : type :> userdata */
-    return 0;
+int *csx_num(int num)
+{
+    return new_num(num);
+}
+
+void *csx_eval(void *expression)
+{
+    return base_eval(expression);
 }
 
-static void *eval_pair(struct csx_pair *pair)
+void *csx_base(csx_base_data base)
 {
-    void *fn;
-    int t = *type(pair->car);
-    if (t == type_fn) fn = pair->car;
-    else              fn = csx_evaluate(pair->car);
-    return eval_fn(fn, pair->cdr);
+    return new_base(base);
 }
 
-void *csx_evaluate(void *expression)
+char *csx_name(const char *name)
 {
-    int t = *type(expression);
-    if (t == type_atom) return lookup(csx.atoms, expression);
-    if (t != type_pair) return nil;
-    return eval_pair(expression);
+    return new_name(name);
 }
-- 
cgit v1.2.3