summaryrefslogtreecommitdiff
path: root/src/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'src/lisp')
-rw-r--r--src/lisp/ao_lisp_atom.c107
-rw-r--r--src/lisp/ao_lisp_builtin.c21
-rw-r--r--src/lisp/ao_lisp_cons.c84
-rw-r--r--src/lisp/ao_lisp_eval.c152
-rw-r--r--src/lisp/ao_lisp_int.c21
-rw-r--r--src/lisp/ao_lisp_lex.c146
-rw-r--r--src/lisp/ao_lisp_mem.c246
-rw-r--r--src/lisp/ao_lisp_poly.c132
-rw-r--r--src/lisp/ao_lisp_prim.c71
-rw-r--r--src/lisp/ao_lisp_string.c87
10 files changed, 1067 insertions, 0 deletions
diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c
new file mode 100644
index 00000000..65282142
--- /dev/null
+++ b/src/lisp/ao_lisp_atom.c
@@ -0,0 +1,107 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; version 2 of the License.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+ */
+
+#include "ao_lisp.h"
+
+static int name_size(char *name)
+{
+ return sizeof(struct ao_lisp_atom) + strlen(name) + 1;
+}
+
+static int atom_size(void *addr)
+{
+ struct ao_lisp_atom *atom = addr;
+ if (!atom)
+ return 0;
+ return name_size(atom->name);
+}
+
+static void atom_mark(void *addr)
+{
+ struct ao_lisp_atom *atom = addr;
+
+ if (atom->next == AO_LISP_ATOM_CONST)
+ return;
+
+ for (;;) {
+ ao_lisp_poly_mark(atom->val);
+ atom = atom->next;
+ if (!atom)
+ break;
+ if (ao_lisp_mark_memory(atom, atom_size(atom)))
+ break;
+ }
+}
+
+static void atom_move(void *addr)
+{
+ struct ao_lisp_atom *atom = addr;
+
+ if (atom->next == AO_LISP_ATOM_CONST)
+ return;
+
+ for (;;) {
+ struct ao_lisp_atom *next;
+
+ atom->val = ao_lisp_poly_move(atom->val);
+ next = ao_lisp_move_memory(atom->next, atom_size(atom->next));
+ if (!next)
+ break;
+ atom->next = next;
+ atom = next;
+ }
+}
+
+const struct ao_lisp_mem_type ao_lisp_atom_type = {
+ .mark = atom_mark,
+ .size = atom_size,
+ .move = atom_move,
+};
+
+struct ao_lisp_atom *atoms;
+
+struct ao_lisp_atom *
+ao_lisp_atom_intern(char *name)
+{
+ struct ao_lisp_atom *atom;
+ int b;
+
+ for (atom = atoms; atom; atom = atom->next) {
+ if (!strcmp(atom->name, name))
+ return atom;
+ }
+ for (b = 0; ao_lisp_builtins[b]; b++)
+ if (!strcmp(ao_lisp_builtins[b]->name, name))
+ return (struct ao_lisp_atom *) ao_lisp_builtins[b];
+ if (!atoms)
+ ao_lisp_root_add(&ao_lisp_atom_type, (void **) &atoms);
+ atom = ao_lisp_alloc(name_size(name));
+ if (atom) {
+ atom->type = AO_LISP_ATOM;
+ atom->next = atoms;
+ atoms = atom;
+ strcpy(atom->name, name);
+ atom->val = AO_LISP_NIL;
+ }
+ return atom;
+}
+
+void
+ao_lisp_atom_print(struct ao_lisp_atom *a)
+{
+ fputs(a->name, stdout);
+}
diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
new file mode 100644
index 00000000..3752a2c8
--- /dev/null
+++ b/src/lisp/ao_lisp_builtin.c
@@ -0,0 +1,21 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+void
+ao_lisp_builtin_print(struct ao_lisp_builtin *b)
+{
+ printf("[builtin %s]", b->name);
+}
diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c
new file mode 100644
index 00000000..60cbb2f3
--- /dev/null
+++ b/src/lisp/ao_lisp_cons.c
@@ -0,0 +1,84 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+static void cons_mark(void *addr)
+{
+ struct ao_lisp_cons *cons = addr;
+
+ for (;;) {
+ ao_lisp_poly_mark(cons->car);
+ cons = cons->cdr;
+ if (!cons)
+ break;
+ if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons)))
+ break;
+ }
+}
+
+static int cons_size(void *addr)
+{
+ (void) addr;
+ return sizeof (struct ao_lisp_cons);
+}
+
+static void cons_move(void *addr)
+{
+ struct ao_lisp_cons *cons = addr;
+
+ for (;;) {
+ struct ao_lisp_cons *cdr;
+
+ cons->car = ao_lisp_poly_move(cons->car);
+ cdr = ao_lisp_move_memory(cons->cdr, sizeof (struct ao_lisp_cons));
+ if (!cdr)
+ break;
+ cons->cdr = cdr;
+ cons = cdr;
+ }
+}
+
+const struct ao_lisp_mem_type ao_lisp_cons_type = {
+ .mark = cons_mark,
+ .size = cons_size,
+ .move = cons_move,
+};
+
+struct ao_lisp_cons *
+ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr)
+{
+ struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons));
+ if (!cons)
+ return NULL;
+ cons->car = car;
+ cons->cdr = cdr;
+ return cons;
+}
+
+void
+ao_lisp_cons_print(struct ao_lisp_cons *cons)
+{
+ int first = 1;
+ printf("(");
+ while (cons) {
+ if (!first)
+ printf(" ");
+ fflush(stdout);
+ ao_lisp_poly_print(cons->car);
+ cons = cons->cdr;
+ first = 0;
+ }
+ printf(")");
+}
diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c
new file mode 100644
index 00000000..531e3b72
--- /dev/null
+++ b/src/lisp/ao_lisp_eval.c
@@ -0,0 +1,152 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+/*
+ * Non-recursive eval
+ *
+ * Plan: walk actuals, construct formals
+ *
+ * stack > save > actuals > actual_1
+ * v v
+ * formals . > actual_2
+ */
+
+static struct ao_lisp_cons *stack;
+static struct ao_lisp_cons *actuals;
+static struct ao_lisp_cons *formals;
+static struct ao_lisp_cons *formals_tail;
+static uint8_t been_here;
+
+ao_lisp_poly
+ao_lisp_eval(ao_lisp_poly v)
+{
+ struct ao_lisp_cons *formal;
+ int cons = 0;
+
+ if (!been_here) {
+ been_here = 1;
+ ao_lisp_root_add(&ao_lisp_cons_type, &stack);
+ ao_lisp_root_add(&ao_lisp_cons_type, &actuals);
+ ao_lisp_root_add(&ao_lisp_cons_type, &formals);
+ ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail);
+ }
+ stack = 0;
+ actuals = 0;
+ formals = 0;
+ formals_tail = 0;
+ for (;;) {
+
+ /* Build stack frames for each list */
+ while (ao_lisp_poly_type(v) == AO_LISP_CONS) {
+ if (v == AO_LISP_NIL)
+ break;
+
+ /* Push existing frame on the stack */
+ if (cons++) {
+ struct ao_lisp_cons *frame;
+
+ frame = ao_lisp_cons(ao_lisp_cons_poly(actuals), formals);
+ stack = ao_lisp_cons(ao_lisp_cons_poly(frame), stack);
+ }
+ actuals = ao_lisp_poly_cons(v);
+ formals = NULL;
+ formals_tail = NULL;
+ v = actuals->car;
+
+ printf("start: stack"); ao_lisp_cons_print(stack); printf("\n");
+ printf("start: actuals"); ao_lisp_cons_print(actuals); printf("\n");
+ printf("start: formals"); ao_lisp_cons_print(formals); printf("\n");
+ }
+
+ /* Evaluate primitive types */
+
+ switch (ao_lisp_poly_type(v)) {
+ case AO_LISP_INT:
+ case AO_LISP_STRING:
+ break;
+ case AO_LISP_ATOM:
+ v = ao_lisp_poly_atom(v)->val;
+ break;
+ }
+
+ for (;;) {
+ printf("add formal: "); ao_lisp_poly_print(v); printf("\n");
+
+ formal = ao_lisp_cons(v, NULL);
+ if (formals_tail)
+ formals_tail->cdr = formal;
+ else
+ formals = formal;
+ formals_tail = formal;
+ actuals = actuals->cdr;
+
+ printf("formals: ");
+ ao_lisp_cons_print(formals);
+ printf("\n");
+ printf("actuals: ");
+ ao_lisp_cons_print(actuals);
+ printf("\n");
+
+ /* Process all of the arguments */
+ if (actuals) {
+ v = actuals->car;
+ printf ("actual: "); ao_lisp_poly_print(v); printf("\n");
+ break;
+ }
+
+ v = formals->car;
+
+ /* Evaluate the resulting list */
+ if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
+ struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
+
+ v = b->func(formals->cdr);
+
+ printf ("eval: ");
+ ao_lisp_cons_print(formals);
+ printf(" -> ");
+ ao_lisp_poly_print(v);
+ printf ("\n");
+ } else {
+ printf ("invalid eval\n");
+ }
+
+ if (--cons) {
+ struct ao_lisp_cons *frame;
+
+ /* Pop the previous frame off the stack */
+ frame = ao_lisp_poly_cons(stack->car);
+ actuals = ao_lisp_poly_cons(frame->car);
+ formals = frame->cdr;
+
+ /* Recompute the tail of the formals list */
+ for (formal = formals; formal->cdr != NULL; formal = formal->cdr);
+ formals_tail = formal;
+
+ stack = stack->cdr;
+ printf("stack pop: stack"); ao_lisp_cons_print(stack); printf("\n");
+ printf("stack pop: actuals"); ao_lisp_cons_print(actuals); printf("\n");
+ printf("stack pop: formals"); ao_lisp_cons_print(formals); printf("\n");
+ } else {
+ printf("done func\n");
+ break;
+ }
+ }
+ if (!cons)
+ break;
+ }
+ return v;
+}
diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c
new file mode 100644
index 00000000..6ee3096d
--- /dev/null
+++ b/src/lisp/ao_lisp_int.c
@@ -0,0 +1,21 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+void
+ao_lisp_int_print(int i)
+{
+ printf("%d", i);
+}
diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c
new file mode 100644
index 00000000..d62db872
--- /dev/null
+++ b/src/lisp/ao_lisp_lex.c
@@ -0,0 +1,146 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+const uint32_t classTable[256] = {
+ IGNORE, /* ^@ */
+ IGNORE, /* ^A */
+ IGNORE, /* ^B */
+ IGNORE, /* ^C */
+ IGNORE, /* ^D */
+ IGNORE, /* ^E */
+ IGNORE, /* ^F */
+ IGNORE, /* ^G */
+ IGNORE, /* ^H */
+ WHITE, /* ^I */
+ WHITE, /* ^J */
+ WHITE, /* ^K */
+ WHITE, /* ^L */
+ WHITE, /* ^M */
+ IGNORE, /* ^N */
+ IGNORE, /* ^O */
+ IGNORE, /* ^P */
+ IGNORE, /* ^Q */
+ IGNORE, /* ^R */
+ IGNORE, /* ^S */
+ IGNORE, /* ^T */
+ IGNORE, /* ^U */
+ IGNORE, /* ^V */
+ IGNORE, /* ^W */
+ IGNORE, /* ^X */
+ IGNORE, /* ^Y */
+ IGNORE, /* ^Z */
+ IGNORE, /* ^[ */
+ IGNORE, /* ^\ */
+ IGNORE, /* ^] */
+ IGNORE, /* ^^ */
+ IGNORE, /* ^_ */
+ PRINTABLE|WHITE, /* */
+ PRINTABLE, /* ! */
+ PRINTABLE|STRINGC, /* " */
+ PRINTABLE|COMMENT, /* # */
+ PRINTABLE, /* $ */
+ PRINTABLE, /* % */
+ PRINTABLE, /* & */
+ PRINTABLE|QUOTEC, /* ' */
+ PRINTABLE|BRA, /* ( */
+ PRINTABLE|KET, /* ) */
+ PRINTABLE, /* * */
+ PRINTABLE|SIGN, /* + */
+ PRINTABLE, /* , */
+ PRINTABLE|SIGN, /* - */
+ PRINTABLE|DOT, /* . */
+ PRINTABLE, /* / */
+ PRINTABLE|DIGIT, /* 0 */
+ PRINTABLE|DIGIT, /* 1 */
+ PRINTABLE|DIGIT, /* 2 */
+ PRINTABLE|DIGIT, /* 3 */
+ PRINTABLE|DIGIT, /* 4 */
+ PRINTABLE|DIGIT, /* 5 */
+ PRINTABLE|DIGIT, /* 6 */
+ PRINTABLE|DIGIT, /* 7 */
+ PRINTABLE|DIGIT, /* 8 */
+ PRINTABLE|DIGIT, /* 9 */
+ PRINTABLE, /* : */
+ PRINTABLE|COMMENT, /* ; */
+ PRINTABLE, /* < */
+ PRINTABLE, /* = */
+ PRINTABLE, /* > */
+ PRINTABLE, /* ? */
+ PRINTABLE, /* @ */
+ PRINTABLE, /* A */
+ PRINTABLE, /* B */
+ PRINTABLE, /* C */
+ PRINTABLE, /* D */
+ PRINTABLE|EXP, /* E */
+ PRINTABLE, /* F */
+ PRINTABLE, /* G */
+ PRINTABLE, /* H */
+ PRINTABLE, /* I */
+ PRINTABLE, /* J */
+ PRINTABLE, /* K */
+ PRINTABLE, /* L */
+ PRINTABLE, /* M */
+ PRINTABLE, /* N */
+ PRINTABLE, /* O */
+ PRINTABLE, /* P */
+ PRINTABLE, /* Q */
+ PRINTABLE, /* R */
+ PRINTABLE, /* S */
+ PRINTABLE, /* T */
+ PRINTABLE, /* U */
+ PRINTABLE, /* V */
+ PRINTABLE, /* W */
+ PRINTABLE, /* X */
+ PRINTABLE, /* Y */
+ PRINTABLE, /* Z */
+ PRINTABLE|BRA, /* [ */
+ PRINTABLE|BACKSLASH, /* \ */
+ PRINTABLE|KET, /* ] */
+ PRINTABLE, /* ^ */
+ PRINTABLE, /* _ */
+ PRINTABLE, /* ` */
+ PRINTABLE, /* a */
+ PRINTABLE, /* b */
+ PRINTABLE, /* c */
+ PRINTABLE, /* d */
+ PRINTABLE|EXP, /* e */
+ PRINTABLE, /* f */
+ PRINTABLE, /* g */
+ PRINTABLE, /* h */
+ PRINTABLE, /* i */
+ PRINTABLE, /* j */
+ PRINTABLE, /* k */
+ PRINTABLE, /* l */
+ PRINTABLE, /* m */
+ PRINTABLE, /* n */
+ PRINTABLE, /* o */
+ PRINTABLE, /* p */
+ PRINTABLE, /* q */
+ PRINTABLE, /* r */
+ PRINTABLE, /* s */
+ PRINTABLE, /* t */
+ PRINTABLE, /* u */
+ PRINTABLE, /* v */
+ PRINTABLE, /* w */
+ PRINTABLE, /* x */
+ PRINTABLE, /* y */
+ PRINTABLE, /* z */
+ PRINTABLE|BRA, /* { */
+ PRINTABLE|VBAR, /* | */
+ PRINTABLE|KET, /* } */
+ PRINTABLE|TWIDDLE, /* ~ */
+ IGNORE, /* ^? */
+};
diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c
new file mode 100644
index 00000000..f6a108e9
--- /dev/null
+++ b/src/lisp/ao_lisp_mem.c
@@ -0,0 +1,246 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+#include <stdio.h>
+
+uint8_t ao_lisp_pool[AO_LISP_POOL];
+
+struct ao_lisp_root {
+ void **addr;
+ const struct ao_lisp_mem_type *type;
+};
+
+static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT];
+
+static uint8_t ao_lisp_busy[AO_LISP_POOL / 32];
+
+static uint8_t ao_lisp_moving[AO_LISP_POOL / 32];
+
+static uint16_t ao_lisp_top;
+
+static inline void mark(uint8_t *tag, int offset) {
+ int byte = offset >> 5;
+ int bit = (offset >> 2) & 7;
+ tag[byte] |= (1 << bit);
+}
+
+static inline void clear(uint8_t *tag, int offset) {
+ int byte = offset >> 5;
+ int bit = (offset >> 2) & 7;
+ tag[byte] &= ~(1 << bit);
+}
+
+static inline int busy(uint8_t *tag, int offset) {
+ int byte = offset >> 5;
+ int bit = (offset >> 2) & 7;
+ return (tag[byte] >> bit) & 1;
+}
+
+static inline int min(int a, int b) { return a < b ? a : b; }
+static inline int max(int a, int b) { return a > b ? a : b; }
+
+static inline int limit(int offset) {
+ return min(AO_LISP_POOL, max(offset, 0));
+}
+
+static int
+mark_object(uint8_t *tag, void *addr, int size) {
+ int base;
+ int bound;
+ if (!addr)
+ return 1;
+
+ base = (uint8_t *) addr - ao_lisp_pool;
+ bound = base + size;
+
+ base = limit(base);
+ bound = limit(bound);
+ if (busy(tag, base))
+ return 1;
+ while (base < bound) {
+ mark(tag, base);
+ base += 4;
+ }
+ return 0;
+}
+
+static int
+clear_object(uint8_t *tag, void *addr, int size) {
+ int base;
+ int bound;
+ if (!addr)
+ return 1;
+
+ base = (uint8_t *) addr - ao_lisp_pool;
+ bound = base + size;
+
+ base = limit(base);
+ bound = limit(bound);
+ if (!busy(tag, base))
+ return 1;
+ while (base < bound) {
+ clear(tag, base);
+ base += 4;
+ }
+ return 0;
+}
+
+static void *move_old, *move_new;
+static int move_size;
+
+static void
+move_object(void)
+{
+ int i;
+
+ memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving));
+ for (i = 0; i < AO_LISP_ROOT; i++)
+ if (ao_lisp_root[i].addr) {
+ void *new;
+ new = ao_lisp_move(ao_lisp_root[i].type, *ao_lisp_root[i].addr);
+ if (new)
+ *ao_lisp_root[i].addr = new;
+ }
+}
+
+static void
+collect(void)
+{
+ int i;
+
+ printf("collect\n");
+ /* Mark */
+ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy));
+ for (i = 0; i < AO_LISP_ROOT; i++)
+ if (ao_lisp_root[i].addr)
+ ao_lisp_mark(ao_lisp_root[i].type, *ao_lisp_root[i].addr);
+
+ /* Compact */
+ ao_lisp_top = 0;
+ for (i = 0; i < AO_LISP_POOL; i += 4) {
+ if (!busy(ao_lisp_busy, i))
+ break;
+ }
+ ao_lisp_top = i;
+ while(i < AO_LISP_POOL) {
+ if (busy(ao_lisp_busy, i)) {
+ move_old = &ao_lisp_pool[i];
+ move_new = &ao_lisp_pool[ao_lisp_top];
+ move_size = 0;
+ move_object();
+ clear_object(ao_lisp_busy, move_old, move_size);
+ i += move_size;
+ ao_lisp_top += move_size;
+ } else {
+ i += 4;
+ }
+ }
+}
+
+
+void
+ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr)
+{
+ if (mark_object(ao_lisp_busy, addr, type->size(addr)))
+ return;
+ type->mark(addr);
+}
+
+int
+ao_lisp_mark_memory(void *addr, int size)
+{
+ return mark_object(ao_lisp_busy, addr, size);
+}
+
+static void *
+check_move(void *addr, int size)
+{
+ if (addr == move_old) {
+ memmove(move_new, move_old, size);
+ move_size = (size + 3) & ~3;
+ addr = move_new;
+ }
+ return addr;
+}
+
+void *
+ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr)
+{
+ int size = type->size(addr);
+
+ if (!addr)
+ return NULL;
+
+ addr = check_move(addr, size);
+ if (mark_object(ao_lisp_moving, addr, size))
+ return addr;
+ type->move(addr);
+ return addr;
+}
+
+void *
+ao_lisp_move_memory(void *addr, int size)
+{
+ if (!addr)
+ return NULL;
+
+ addr = check_move(addr, size);
+ if (mark_object(ao_lisp_moving, addr, size))
+ return NULL;
+ return addr;
+}
+
+void *
+ao_lisp_alloc(int size)
+{
+ void *addr;
+
+ size = (size + 3) & ~3;
+ if (ao_lisp_top + size > AO_LISP_POOL) {
+ collect();
+ if (ao_lisp_top + size > AO_LISP_POOL)
+ return NULL;
+ }
+ addr = ao_lisp_pool + ao_lisp_top;
+ ao_lisp_top += size;
+ return addr;
+}
+
+int
+ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr)
+{
+ int i;
+ for (i = 0; i < AO_LISP_ROOT; i++) {
+ if (!ao_lisp_root[i].addr) {
+ ao_lisp_root[i].addr = addr;
+ ao_lisp_root[i].type = type;
+ return 1;
+ }
+ }
+ return 0;
+}
+
+void
+ao_lisp_root_clear(void *addr)
+{
+ int i;
+ for (i = 0; i < AO_LISP_ROOT; i++) {
+ if (ao_lisp_root[i].addr == addr) {
+ ao_lisp_root[i].addr = 0;
+ ao_lisp_root[i].type = 0;
+ break;
+ }
+ }
+}
diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c
new file mode 100644
index 00000000..1855d945
--- /dev/null
+++ b/src/lisp/ao_lisp_poly.c
@@ -0,0 +1,132 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+enum math_op { math_plus, math_minus, math_times, math_divide, math_mod };
+
+ao_lisp_poly
+ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op)
+{
+ ao_lisp_poly ret = AO_LISP_NIL;
+
+ while (cons) {
+ ao_lisp_poly car = cons->car;
+ uint8_t rt = ao_lisp_poly_type(ret);
+ uint8_t ct = ao_lisp_poly_type(car);
+
+ cons = cons->cdr;
+
+ if (rt == AO_LISP_NIL)
+ ret = car;
+
+ else if (rt == AO_LISP_INT && ct == AO_LISP_INT) {
+ int r = ao_lisp_poly_int(ret);
+ int c = ao_lisp_poly_int(car);
+
+ switch(op) {
+ case math_plus:
+ r += c;
+ break;
+ case math_minus:
+ r -= c;
+ break;
+ case math_times:
+ r *= c;
+ break;
+ case math_divide:
+ if (c == 0)
+ return AO_LISP_NIL;
+ r /= c;
+ break;
+ case math_mod:
+ if (c == 0)
+ return AO_LISP_NIL;
+ r %= c;
+ break;
+ }
+ ret = ao_lisp_int_poly(r);
+ }
+
+ else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus)
+ ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret),
+ ao_lisp_poly_string(car)));
+ else {
+ /* XXX exception */
+ return AO_LISP_NIL;
+ }
+ }
+ return ret;
+}
+
+ao_lisp_poly
+ao_lisp_plus(struct ao_lisp_cons *cons)
+{
+ return ao_lisp_math(cons, math_plus);
+}
+
+ao_lisp_poly
+ao_lisp_minus(struct ao_lisp_cons *cons)
+{
+ return ao_lisp_math(cons, math_minus);
+}
+
+ao_lisp_poly
+ao_lisp_times(struct ao_lisp_cons *cons)
+{
+ return ao_lisp_math(cons, math_times);
+}
+
+ao_lisp_poly
+ao_lisp_divide(struct ao_lisp_cons *cons)
+{
+ return ao_lisp_math(cons, math_divide);
+}
+
+ao_lisp_poly
+ao_lisp_mod(struct ao_lisp_cons *cons)
+{
+ return ao_lisp_math(cons, math_mod);
+}
+
+static const struct ao_lisp_builtin builtin_plus = {
+ .type = AO_LISP_BUILTIN,
+ .func = ao_lisp_plus,
+ .name = "+"
+};
+
+static const struct ao_lisp_atom atom_plus = {
+ .type = AO_LISP_ATOM,
+ .val = AO_LISP_OTHER_POLY(&builtin_plus),
+ .next = AO_LISP_ATOM_CONST,
+ .name = "plus"
+};
+
+/*
+static const struct ao_lisp_builtin builtin_minus = {
+ .type = AO_LISP_BUILTIN,
+ .func = ao_lisp_minus
+};
+
+static const struct ao_lisp_builtin builtin_times = {
+ .type = AO_LISP_BUILTIN,
+ .func = ao_lisp_times
+};
+
+*/
+
+const struct ao_lisp_atom const *ao_lisp_builtins[] = {
+ &atom_plus,
+ 0
+};
diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c
new file mode 100644
index 00000000..ccfd2be4
--- /dev/null
+++ b/src/lisp/ao_lisp_prim.c
@@ -0,0 +1,71 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#include "ao_lisp.h"
+
+ao_lisp_poly
+ao_lisp_poly_print(ao_lisp_poly p)
+{
+ switch (ao_lisp_poly_type(p)) {
+ case AO_LISP_CONS:
+ ao_lisp_cons_print(ao_lisp_poly_cons(p));
+ break;
+ case AO_LISP_STRING:
+ ao_lisp_string_print(ao_lisp_poly_string(p));
+ break;
+ case AO_LISP_INT:
+ ao_lisp_int_print(ao_lisp_poly_int(p));
+ break;
+ case AO_LISP_ATOM:
+ ao_lisp_atom_print(ao_lisp_poly_atom(p));
+ break;
+ case AO_LISP_BUILTIN:
+ ao_lisp_builtin_print(ao_lisp_poly_builtin(p));
+ break;
+ }
+ return AO_LISP_NIL;
+}
+
+void
+ao_lisp_poly_mark(ao_lisp_poly p)
+{
+ switch (ao_lisp_poly_type(p)) {
+ case AO_LISP_CONS:
+ ao_lisp_mark(&ao_lisp_cons_type, ao_lisp_poly_cons(p));
+ break;
+ case AO_LISP_STRING:
+ ao_lisp_mark(&ao_lisp_string_type, ao_lisp_poly_string(p));
+ break;
+ case AO_LISP_ATOM:
+ ao_lisp_mark(&ao_lisp_atom_type, ao_lisp_poly_atom(p));
+ break;
+ }
+}
+
+ao_lisp_poly
+ao_lisp_poly_move(ao_lisp_poly p)
+{
+ switch (ao_lisp_poly_type(p)) {
+ case AO_LISP_CONS:
+ p = ao_lisp_cons_poly(ao_lisp_move(&ao_lisp_cons_type, ao_lisp_poly_cons(p)));
+ break;
+ case AO_LISP_STRING:
+ p = ao_lisp_string_poly(ao_lisp_move(&ao_lisp_string_type, ao_lisp_poly_string(p)));
+ break;
+ case AO_LISP_ATOM:
+ p = ao_lisp_atom_poly(ao_lisp_move(&ao_lisp_atom_type, ao_lisp_poly_atom(p)));
+ break;
+ }
+ return p;
+}
diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c
new file mode 100644
index 00000000..87024271
--- /dev/null
+++ b/src/lisp/ao_lisp_string.c
@@ -0,0 +1,87 @@
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; version 2 of the License.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
+ */
+
+#include "ao_lisp.h"
+
+static void string_mark(void *addr)
+{
+ (void) addr;
+}
+
+static int string_size(void *addr)
+{
+ if (!addr)
+ return 0;
+ return strlen(addr) + 1;
+}
+
+static void string_move(void *addr)
+{
+ (void) addr;
+}
+
+char *
+ao_lisp_string_new(int len) {
+ char *a = ao_lisp_alloc(len + 1);
+ if (!a)
+ return NULL;
+ a[len] = '\0';
+ return a;
+}
+
+char *
+ao_lisp_string_cat(char *a, char *b)
+{
+ int alen = strlen(a);
+ int blen = strlen(b);
+ char *r = ao_lisp_alloc(alen + blen + 1);
+ if (!r)
+ return NULL;
+ strcpy(r, a);
+ strcpy(r+alen, b);
+ return r;
+}
+
+const struct ao_lisp_mem_type ao_lisp_string_type = {
+ .mark = string_mark,
+ .size = string_size,
+ .move = string_move,
+};
+
+void
+ao_lisp_string_print(char *s)
+{
+ char c;
+ putchar('"');
+ while ((c = *s++)) {
+ switch (c) {
+ case '\n':
+ printf ("\\n");
+ break;
+ case '\r':
+ printf ("\\r");
+ break;
+ case '\t':
+ printf ("\\t");
+ break;
+ default:
+ putchar(c);
+ break;
+ }
+ }
+ putchar('"');
+}
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 05:29:15 +0000