diff options
| -rw-r--r-- | LICENSE | 2 | ||||
| -rw-r--r-- | examples/fib.c | 50 | ||||
| -rw-r--r-- | examples/strfib.c | 53 | ||||
| -rw-r--r-- | include/csx.h | 19 | ||||
| -rw-r--r-- | include/csx/csx.h | 25 | ||||
| -rw-r--r-- | src/csx.c | 604 |
6 files changed, 569 insertions, 184 deletions
@@ -1,4 +1,4 @@ -Copyright 2020 Aleksey Veresov +Copyright 2020-2021 Aleksey Veresov This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from diff --git a/examples/fib.c b/examples/fib.c new file mode 100644 index 0000000..0c94673 --- /dev/null +++ b/examples/fib.c @@ -0,0 +1,50 @@ +#include <csx.h> +#include <stdio.h> + + +static csx_list_fn *l; +static csx_num_fn *n; + +char *define; +char *fn; +char *pair; +char *head; +char *tail; +char *not; +char *csx_if; +char *inc; +char *sum; +char *diff; + +void process() +{ + char *fib = csx_name("fib"); + char *num = csx_name("num"); + csx_eval(l(define, fib, l(fn, l(num, 0), + l(csx_if, l(inc, num, n(2), 0), n(1), + l(sum, + l(fib, l(diff, num, n(1), 0), 0), + l(fib, l(diff, num, n(2), 0), 0), + 0), + 0), + 0), 0)); + printf("fib 6 = %d\n", *(int *)csx_eval(l(fib, n(6), 0))); +} + +int main() +{ + l = csx_list; + n = csx_num; + define = csx_name("define"); + fn = csx_name("fn"); + pair = csx_name("pair"); + head = csx_name("head"); + tail = csx_name("tail"); + not = csx_name("not"); + csx_if = csx_name("if"); + inc = csx_name("inc"); + sum = csx_name("sum"); + diff = csx_name("diff"); + process(); + return 0; +} diff --git a/examples/strfib.c b/examples/strfib.c deleted file mode 100644 index 6e22c7f..0000000 --- a/examples/strfib.c +++ /dev/null @@ -1,53 +0,0 @@ -#include <csx/csx.h> -#include <stdio.h> - - -static csx_type_function_list *l; -static csx_type_function_string *s; -static csx_type_function_atom *a; -static csx_type_function_evaluate *e; - -static char *append; -static char *define; -static char *cdr; -static char *ifx; -static char *not; - -void printfibs(char *strfib) -{ - const char *input = "oooooooooo" + 9; - int i; - for (i = 0; i != 10; ++i) - puts(e(l(strfib, s(input - i), 0))); -} - -void process() -{ - char *strfib = a("strfib"); - char *n = a("n"); - e(l(define, l(strfib, n, 0), - l(ifx, l(not, n, 0), s(""), - l(ifx, l(not, l(cdr, n, 0), 0), s("o"), - l(append, l(strfib, l(cdr, n, 0), 0), - l(strfib, l(cdr, l(cdr, n, 0), 0), 0), 0), - 0), - 0), - 0)); - printfibs(strfib); -} - -int main() -{ - l = csx_list; - s = csx_string; - a = csx_atom; - e = csx_evaluate; - append = a("append"); - define = a("define"); - cdr = a("cdr"); - ifx = a("ifx"); - not = a("not"); - process(); - csx_free(); - return 0; -} diff --git a/include/csx.h b/include/csx.h new file mode 100644 index 0000000..90d18c2 --- /dev/null +++ b/include/csx.h @@ -0,0 +1,19 @@ +#ifndef CSX_INCLUDED +#define CSX_INCLUDED + + +typedef void *(csx_list_fn)(void *head, ...); +void *csx_list(void *head, ...); + +typedef int *(csx_num_fn)(int num); +int *csx_num(int num); + +void *csx_eval(void *expression); + +typedef void *(csx_base_data)(void *arg); +void *csx_base(csx_base_data base); + +char *csx_name(const char *name); + + +#endif diff --git a/include/csx/csx.h b/include/csx/csx.h deleted file mode 100644 index db2d1b3..0000000 --- a/include/csx/csx.h +++ /dev/null @@ -1,25 +0,0 @@ -#ifndef CSX_INCLUDED -#define CSX_INCLUDED - - -struct csx_pair { - void *car; - void *cdr; -}; - -typedef struct csx_pair *(csx_type_function_list)(void *head, ...); -struct csx_pair *csx_list(void *head, ...); - -typedef char *(csx_type_function_string)(const char *string); -char *csx_string(const char *string); - -typedef char *(csx_type_function_atom)(const char *name); -char *csx_atom(const char *name); - -typedef void *(csx_type_function_evaluate)(void *expression); -void *csx_evaluate(void *expression); - -void csx_free(); - - -#endif @@ -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); } |