summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lisp/Makefile3
-rw-r--r--src/lisp/ao_lisp.h105
-rw-r--r--src/lisp/ao_lisp_atom.c51
-rw-r--r--src/lisp/ao_lisp_builtin.c37
-rw-r--r--src/lisp/ao_lisp_cons.c27
-rw-r--r--src/lisp/ao_lisp_eval.c5
-rw-r--r--src/lisp/ao_lisp_frame.c191
-rw-r--r--src/lisp/ao_lisp_make_const.c44
-rw-r--r--src/lisp/ao_lisp_mem.c168
-rw-r--r--src/lisp/ao_lisp_prim.c41
-rw-r--r--src/lisp/ao_lisp_read.c23
-rw-r--r--src/nucleao-32/Makefile3
-rw-r--r--src/test/Makefile4
-rw-r--r--src/test/ao_lisp_test.c3
14 files changed, 597 insertions, 108 deletions
diff --git a/src/lisp/Makefile b/src/lisp/Makefile
index e8c3c02c..9e2fb58c 100644
--- a/src/lisp/Makefile
+++ b/src/lisp/Makefile
@@ -16,7 +16,8 @@ SRCS=\
ao_lisp_poly.c \
ao_lisp_prim.c \
ao_lisp_builtin.c \
- ao_lisp_read.c
+ ao_lisp_read.c \
+ ao_lisp_frame.c
OBJS=$(SRCS:.c=.o)
diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h
index d4108662..98e99acb 100644
--- a/src/lisp/ao_lisp.h
+++ b/src/lisp/ao_lisp.h
@@ -15,9 +15,12 @@
#ifndef _AO_LISP_H_
#define _AO_LISP_H_
+#include <stdlib.h>
+
#if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST)
#include <ao.h>
#define AO_LISP_ALTOS 1
+#define abort() ao_panic(1)
#endif
#include <stdint.h>
@@ -27,9 +30,14 @@
#ifdef AO_LISP_MAKE_CONST
#define AO_LISP_POOL_CONST 16384
extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST];
+#define ao_lisp_pool ao_lisp_const
+#define AO_LISP_POOL AO_LISP_POOL_CONST
#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote"))
+#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set"))
#else
#include "ao_lisp_const.h"
+#define AO_LISP_POOL 1024
+extern uint8_t ao_lisp_pool[AO_LISP_POOL];
#endif
/* Primitive types */
@@ -46,13 +54,11 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST];
/* These have a type value at the start of the struct */
#define AO_LISP_ATOM 4
#define AO_LISP_BUILTIN 5
-#define AO_LISP_NUM_TYPE 6
+#define AO_LISP_FRAME 6
+#define AO_LISP_NUM_TYPE 7
#define AO_LISP_NIL 0
-#define AO_LISP_POOL 1024
-
-extern uint8_t ao_lisp_pool[AO_LISP_POOL];
extern uint16_t ao_lisp_top;
#define AO_LISP_OOM 0x01
@@ -68,37 +74,31 @@ ao_lisp_is_const(ao_poly poly) {
return poly & AO_LISP_CONST;
}
+#define AO_LISP_POOL_BASE (ao_lisp_pool - 4)
+#define AO_LISP_CONST_BASE (ao_lisp_const - 4)
+
+#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST)
+#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL)
+
static inline void *
ao_lisp_ref(ao_poly poly) {
if (poly == AO_LISP_NIL)
return NULL;
if (poly & AO_LISP_CONST)
- return (void *) ((ao_lisp_const - 4) + (poly & AO_LISP_REF_MASK));
- else
- return (void *) ((ao_lisp_pool - 4) + (poly & AO_LISP_REF_MASK));
+ return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK));
+ return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK));
}
static inline ao_poly
ao_lisp_poly(const void *addr, ao_poly type) {
const uint8_t *a = addr;
- if (addr == NULL)
+ if (a == NULL)
return AO_LISP_NIL;
- if (ao_lisp_pool <= a && a < ao_lisp_pool + AO_LISP_POOL)
- return (a - (ao_lisp_pool - 4)) | type;
- else if (ao_lisp_const <= a && a <= ao_lisp_const + AO_LISP_POOL_CONST)
- return AO_LISP_CONST | (a - (ao_lisp_const - 4)) | type;
- else {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
- }
+ if (AO_LISP_IS_CONST(a))
+ return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type;
+ return (a - AO_LISP_POOL_BASE) | type;
}
-#define AO_LISP_POLY(addr, type) (((ao_lisp_pool <= ((uint8_t *) (a)) && \
- ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) ? \
- ((uint8_t *) (a) - (ao_lisp_pool - 4)) : \
- (((uint8_t *) (a) - (ao_lisp_const - 4)) | AO_LISP_POOL_CONST)) | \
- (type))
-
struct ao_lisp_type {
void (*mark)(void *addr);
int (*size)(void *addr);
@@ -113,11 +113,32 @@ struct ao_lisp_cons {
struct ao_lisp_atom {
uint8_t type;
uint8_t pad[1];
- ao_poly val;
ao_poly next;
char name[];
};
+struct ao_lisp_val {
+ ao_poly atom;
+ ao_poly val;
+};
+
+struct ao_lisp_frame {
+ uint8_t num;
+ uint8_t readonly;
+ ao_poly next;
+ struct ao_lisp_val vals[];
+};
+
+static inline struct ao_lisp_frame *
+ao_lisp_poly_frame(ao_poly poly) {
+ return ao_lisp_ref(poly);
+}
+
+static inline ao_poly
+ao_lisp_frame_poly(struct ao_lisp_frame *frame) {
+ return ao_lisp_poly(frame, AO_LISP_OTHER);
+}
+
#define AO_LISP_LAMBDA 0
#define AO_LISP_NLAMBDA 1
#define AO_LISP_MACRO 2
@@ -160,6 +181,11 @@ ao_lisp_poly_other(ao_poly poly) {
return ao_lisp_ref(poly);
}
+static inline uint8_t
+ao_lisp_other_type(void *other) {
+ return *((uint8_t *) other);
+}
+
static inline ao_poly
ao_lisp_other_poly(const void *other)
{
@@ -175,9 +201,9 @@ ao_lisp_mem_round(int size)
#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER)
static inline int ao_lisp_poly_type(ao_poly poly) {
- int type = poly & 3;
+ int type = poly & AO_LISP_TYPE_MASK;
if (type == AO_LISP_OTHER)
- return *((uint8_t *) ao_lisp_poly_other(poly));
+ return ao_lisp_other_type(ao_lisp_poly_other(poly));
return type;
}
@@ -250,6 +276,9 @@ int
ao_lisp_mark_memory(void *addr, int size);
void *
+ao_lisp_move_map(void *addr);
+
+void *
ao_lisp_move(const struct ao_lisp_type *type, void *addr);
/* returns NULL if the object was already moved */
@@ -259,6 +288,9 @@ ao_lisp_move_memory(void *addr, int size);
void *
ao_lisp_alloc(int size);
+void
+ao_lisp_collect(void);
+
int
ao_lisp_root_add(const struct ao_lisp_type *type, void *addr);
@@ -303,6 +335,12 @@ ao_lisp_atom_print(ao_poly a);
struct ao_lisp_atom *
ao_lisp_atom_intern(char *name);
+ao_poly
+ao_lisp_atom_get(ao_poly atom);
+
+ao_poly
+ao_lisp_atom_set(ao_poly atom, ao_poly val);
+
/* int */
void
ao_lisp_int_print(ao_poly i);
@@ -325,6 +363,8 @@ ao_lisp_eval(ao_poly p);
void
ao_lisp_builtin_print(ao_poly b);
+extern const struct ao_lisp_type ao_lisp_builtin_type;
+
/* read */
ao_poly
ao_lisp_read(void);
@@ -333,4 +373,19 @@ ao_lisp_read(void);
ao_poly
ao_lisp_read_eval_print(void);
+/* frame */
+extern const struct ao_lisp_type ao_lisp_frame_type;
+
+int
+ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val);
+
+ao_poly
+ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom);
+
+struct ao_lisp_frame *
+ao_lisp_frame_new(int num, int readonly);
+
+struct ao_lisp_frame *
+ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val);
+
#endif /* _AO_LISP_H_ */
diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c
index aaa84b8d..e5d28c3b 100644
--- a/src/lisp/ao_lisp_atom.c
+++ b/src/lisp/ao_lisp_atom.c
@@ -17,6 +17,12 @@
#include "ao_lisp.h"
+#if 0
+#define DBG(...) printf(__VA_ARGS__)
+#else
+#define DBG(...)
+#endif
+
static int name_size(char *name)
{
return sizeof(struct ao_lisp_atom) + strlen(name) + 1;
@@ -34,31 +40,38 @@ static void atom_mark(void *addr)
{
struct ao_lisp_atom *atom = addr;
+ DBG ("\tatom start %s\n", atom->name);
for (;;) {
- ao_lisp_poly_mark(atom->val);
atom = ao_lisp_poly_atom(atom->next);
if (!atom)
break;
+ DBG("\t\tatom mark %s %d\n", atom->name, (uint8_t *) atom - ao_lisp_const);
if (ao_lisp_mark_memory(atom, atom_size(atom)))
break;
}
+ DBG ("\tatom done\n");
}
static void atom_move(void *addr)
{
struct ao_lisp_atom *atom = addr;
+ DBG("\tatom move start %s %d next %s %d\n",
+ atom->name, ((uint8_t *) atom - ao_lisp_const),
+ atom->next ? ao_lisp_poly_atom(atom->next)->name : "(none)",
+ atom->next ? ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const) : 0);
for (;;) {
struct ao_lisp_atom *next;
- atom->val = ao_lisp_poly_move(atom->val);
next = ao_lisp_poly_atom(atom->next);
next = ao_lisp_move_memory(next, atom_size(next));
if (!next)
break;
+ DBG("\t\tatom move %s %d->%d\n", next->name, ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const), ((uint8_t *) next - ao_lisp_const));
atom->next = ao_lisp_atom_poly(next);
atom = next;
}
+ DBG("\tatom move end\n");
}
const struct ao_lisp_type ao_lisp_atom_type = {
@@ -73,7 +86,6 @@ struct ao_lisp_atom *
ao_lisp_atom_intern(char *name)
{
struct ao_lisp_atom *atom;
-// int b;
for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) {
if (!strcmp(atom->name, name))
@@ -85,19 +97,46 @@ ao_lisp_atom_intern(char *name)
return atom;
}
#endif
- if (!ao_lisp_atoms)
- ao_lisp_root_add(&ao_lisp_atom_type, (void **) &ao_lisp_atoms);
atom = ao_lisp_alloc(name_size(name));
if (atom) {
atom->type = AO_LISP_ATOM;
atom->next = ao_lisp_atom_poly(ao_lisp_atoms);
+ if (!ao_lisp_atoms)
+ ao_lisp_root_add(&ao_lisp_atom_type, &ao_lisp_atoms);
ao_lisp_atoms = atom;
strcpy(atom->name, name);
- atom->val = AO_LISP_NIL;
}
return atom;
}
+static struct ao_lisp_frame *globals;
+
+ao_poly
+ao_lisp_atom_get(ao_poly atom)
+{
+ struct ao_lisp_frame *frame = globals;
+#ifdef ao_builtin_frame
+ if (!frame)
+ frame = ao_lisp_poly_frame(ao_builtin_frame);
+#endif
+ return ao_lisp_frame_get(frame, atom);
+}
+
+ao_poly
+ao_lisp_atom_set(ao_poly atom, ao_poly val)
+{
+ if (!ao_lisp_frame_set(globals, atom, val)) {
+ globals = ao_lisp_frame_add(globals, atom, val);
+ if (!globals->next) {
+ ao_lisp_root_add(&ao_lisp_frame_type, &globals);
+#ifdef ao_builtin_frame
+ globals->next = ao_builtin_frame;
+#endif
+ }
+ }
+ return val;
+}
+
void
ao_lisp_atom_print(ao_poly a)
{
diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c
index 63fb69fd..8c481793 100644
--- a/src/lisp/ao_lisp_builtin.c
+++ b/src/lisp/ao_lisp_builtin.c
@@ -14,6 +14,31 @@
#include "ao_lisp.h"
+static int
+builtin_size(void *addr)
+{
+ (void) addr;
+ return sizeof (struct ao_lisp_builtin);
+}
+
+static void
+builtin_mark(void *addr)
+{
+ (void) addr;
+}
+
+static void
+builtin_move(void *addr)
+{
+ (void) addr;
+}
+
+const struct ao_lisp_type ao_lisp_builtin_type = {
+ .size = builtin_size,
+ .mark = builtin_mark,
+ .move = builtin_move
+};
+
void
ao_lisp_builtin_print(ao_poly b)
{
@@ -120,20 +145,12 @@ ao_lisp_quote(struct ao_lisp_cons *cons)
ao_poly
ao_lisp_set(struct ao_lisp_cons *cons)
{
- ao_poly atom, val;
if (!check_argc(cons, 2, 2))
return AO_LISP_NIL;
if (!check_argt(cons, 0, AO_LISP_ATOM, 0))
return AO_LISP_NIL;
- atom = cons->car;
- val = ao_lisp_poly_cons(cons->cdr)->car;
- if (ao_lisp_is_const(atom)) {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
- }
- ao_lisp_poly_atom(atom)->val = val;
- return val;
+ return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car);
}
ao_poly
@@ -157,6 +174,8 @@ ao_lisp_print(struct ao_lisp_cons *cons)
val = cons->car;
ao_lisp_poly_print(val);
cons = ao_lisp_poly_cons(cons->cdr);
+ if (cons)
+ printf(" ");
}
return val;
}
diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c
index 65908e30..f8a34ed4 100644
--- a/src/lisp/ao_lisp_cons.c
+++ b/src/lisp/ao_lisp_cons.c
@@ -14,6 +14,23 @@
#include "ao_lisp.h"
+#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const))
+
+#if 0
+static int cons_depth;
+#define DBG(...) do { int d; for (d = 0; d < cons_depth; d++) printf (" "); printf(__VA_ARGS__); } while(0)
+#define DBG_IN() (cons_depth++)
+#define DBG_OUT() (cons_depth--)
+#define DBG_PR(c) ao_lisp_cons_print(ao_lisp_cons_poly(c))
+#define DBG_PRP(p) ao_lisp_poly_print(p)
+#else
+#define DBG(...)
+#define DBG_IN()
+#define DBG_OUT()
+#define DBG_PR(c)
+#define DBG_PRP(p)
+#endif
+
static void cons_mark(void *addr)
{
struct ao_lisp_cons *cons = addr;
@@ -38,17 +55,25 @@ static void cons_move(void *addr)
{
struct ao_lisp_cons *cons = addr;
+ DBG_IN();
+ DBG("move cons start %d\n", OFFSET(cons));
for (;;) {
struct ao_lisp_cons *cdr;
+ ao_poly car;
- cons->car = ao_lisp_poly_move(cons->car);
+ car = ao_lisp_poly_move(cons->car);
+ DBG(" moved car %d -> %d\n", OFFSET(ao_lisp_ref(cons->car)), OFFSET(ao_lisp_ref(car)));
+ cons->car = car;
cdr = ao_lisp_poly_cons(cons->cdr);
cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons));
if (!cdr)
break;
+ DBG(" moved cdr %d -> %d\n", OFFSET(ao_lisp_poly_cons(cons->cdr)), OFFSET(cdr));
cons->cdr = ao_lisp_cons_poly(cdr);
cons = cdr;
}
+ DBG("move cons end\n");
+ DBG_OUT();
}
const struct ao_lisp_type ao_lisp_cons_type = {
diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c
index 2374fdb2..6eef1f23 100644
--- a/src/lisp/ao_lisp_eval.c
+++ b/src/lisp/ao_lisp_eval.c
@@ -91,7 +91,7 @@ ao_lisp_eval(ao_poly v)
case AO_LISP_STRING:
break;
case AO_LISP_ATOM:
- v = ao_lisp_poly_atom(v)->val;
+ v = ao_lisp_atom_get(v);
break;
}
@@ -187,6 +187,9 @@ ao_lisp_eval(ao_poly v)
DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
} else {
+ actuals = 0;
+ formals = 0;
+ formals_tail = 0;
DBG("done func\n");
break;
}
diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c
new file mode 100644
index 00000000..5aa50f6b
--- /dev/null
+++ b/src/lisp/ao_lisp_frame.c
@@ -0,0 +1,191 @@
+/*
+ * 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"
+
+#if 0
+#define DBG(...) printf(__VA_ARGS__)
+#else
+#define DBG(...)
+#endif
+
+static inline int
+frame_num_size(int num)
+{
+ return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val);
+}
+
+static int
+frame_size(void *addr)
+{
+ struct ao_lisp_frame *frame = addr;
+ return frame_num_size(frame->num);
+}
+
+#define OFFSET(a) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const)
+
+static void
+frame_mark(void *addr)
+{
+ struct ao_lisp_frame *frame = addr;
+ int f;
+
+ for (;;) {
+ if (frame->readonly)
+ break;
+ for (f = 0; f < frame->num; f++) {
+ struct ao_lisp_val *v = &frame->vals[f];
+
+ ao_lisp_poly_mark(v->atom);
+ ao_lisp_poly_mark(v->val);
+ DBG ("\tframe mark atom %s %d val %d at %d\n", ao_lisp_poly_atom(v->atom)->name, OFFSET(v->atom), OFFSET(v->val), f);
+ }
+ frame = ao_lisp_poly_frame(frame->next);
+ if (!frame)
+ break;
+ if (ao_lisp_mark_memory(frame, frame_size(frame)))
+ break;
+ }
+}
+
+static void
+frame_move(void *addr)
+{
+ struct ao_lisp_frame *frame = addr;
+ int f;
+
+ for (;;) {
+ struct ao_lisp_frame *next;
+ if (frame->readonly)
+ break;
+ for (f = 0; f < frame->num; f++) {
+ struct ao_lisp_val *v = &frame->vals[f];
+ ao_poly t;
+
+ t = ao_lisp_poly_move(v->atom);
+ DBG("\t\tatom %s %d -> %d\n", ao_lisp_poly_atom(t)->name, OFFSET(v->atom), OFFSET(t));
+ v->atom = t;
+ t = ao_lisp_poly_move(v->val);
+ DBG("\t\tval %d -> %d\n", OFFSET(v->val), OFFSET(t));
+ v->val = t;
+ }
+ next = ao_lisp_poly_frame(frame->next);
+ if (!next)
+ break;
+ next = ao_lisp_move_memory(next, frame_size(next));
+ frame->next = ao_lisp_frame_poly(next);
+ frame = next;
+ }
+}
+
+const struct ao_lisp_type ao_lisp_frame_type = {
+ .mark = frame_mark,
+ .size = frame_size,
+ .move = frame_move
+};
+
+static ao_poly *
+ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom)
+{
+ int f;
+ for (f = 0; f < frame->num; f++)
+ if (frame->vals[f].atom == atom)
+ return &frame->vals[f].val;
+ return NULL;
+}
+
+int
+ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val)
+{
+ while (frame) {
+ if (!frame->readonly) {
+ ao_poly *ref = ao_lisp_frame_ref(frame, atom);
+ if (ref) {
+ *ref = val;
+ return 1;
+ }
+ }
+ frame = ao_lisp_poly_frame(frame->next);
+ }
+ return 0;
+}
+
+ao_poly
+ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom)
+{
+ while (frame) {
+ ao_poly *ref = ao_lisp_frame_ref(frame, atom);
+ if (ref)
+ return *ref;
+ frame = ao_lisp_poly_frame(frame->next);
+ }
+ return AO_LISP_NIL;
+}
+
+struct ao_lisp_frame *
+ao_lisp_frame_new(int num, int readonly)
+{
+ struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num));
+
+ if (!frame)
+ return NULL;
+ frame->num = num;
+ frame->readonly = readonly;
+ frame->next = AO_LISP_NIL;
+ memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val));
+ return frame;
+}
+
+static struct ao_lisp_frame *
+ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num, int readonly)
+{
+ struct ao_lisp_frame *new;
+ int copy;
+
+ if (new_num == frame->num)
+ return frame;
+ new = ao_lisp_frame_new(new_num, readonly);
+ if (!new)
+ return NULL;
+ copy = new_num;
+ if (copy > frame->num)
+ copy = frame->num;
+ memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val));
+ if (frame)
+ new->next = frame->next;
+ return new;
+}
+
+struct ao_lisp_frame *
+ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val)
+{
+ ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL;
+ if (!ref) {
+ int f;
+ if (frame) {
+ f = frame->num;
+ frame = ao_lisp_frame_realloc(frame, f + 1, frame->readonly);
+ } else {
+ f = 0;
+ frame = ao_lisp_frame_new(1, 0);
+ }
+ if (!frame)
+ return NULL;
+ DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f);
+ frame->vals[f].atom = atom;
+ ref = &frame->vals[f].val;
+ }
+ *ref = val;
+ return frame;
+}
diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c
index 8d3e03a9..6b603979 100644
--- a/src/lisp/ao_lisp_make_const.c
+++ b/src/lisp/ao_lisp_make_const.c
@@ -49,19 +49,43 @@ struct builtin_func funcs[] = {
#define N_FUNC (sizeof funcs / sizeof funcs[0])
+struct ao_lisp_frame *globals;
+
+static int
+is_atom(int offset)
+{
+ struct ao_lisp_atom *a;
+
+ for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next))
+ if (((uint8_t *) a->name - ao_lisp_const) == offset)
+ return strlen(a->name);
+ return 0;
+}
+
int
main(int argc, char **argv)
{
int f, o;
ao_poly atom, val;
struct ao_lisp_atom *a;
+ int in_atom;
+ printf("/*\n");
+ printf(" * Generated file, do not edit\n");
+ ao_lisp_root_add(&ao_lisp_frame_type, &globals);
+ globals = ao_lisp_frame_new(0, 0);
for (f = 0; f < N_FUNC; f++) {
struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args);
struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name);
- a->val = ao_lisp_builtin_poly(b);
+ globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b));
}
+ /* boolean constants */
+ a = ao_lisp_atom_intern("nil");
+ globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL);
+ a = ao_lisp_atom_intern("t");
+ globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a));
+
for (;;) {
atom = ao_lisp_read();
if (!atom)
@@ -73,13 +97,19 @@ main(int argc, char **argv)
fprintf(stderr, "input must be atom val pairs\n");
exit(1);
}
- ao_lisp_poly_atom(atom)->val = val;
+ globals = ao_lisp_frame_add(globals, atom, val);
}
- printf("/* constant objects, all referenced from atoms */\n\n");
+ /* Reduce to referenced values */
+ ao_lisp_collect();
+ printf(" */\n");
+
+ globals->readonly = 1;
+
printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top);
printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n");
printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms));
+ printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals));
for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) {
char *n = a->name, c;
@@ -101,10 +131,14 @@ main(int argc, char **argv)
else
printf(" ");
c = ao_lisp_const[o];
- if (' ' < c && c <= '~' && c != '\'')
+ if (!in_atom)
+ in_atom = is_atom(o);
+ if (in_atom) {
printf (" '%c',", c);
- else
+ in_atom--;
+ } else {
printf("0x%02x,", c);
+ }
}
printf("\n};\n");
printf("#endif /* AO_LISP_CONST_BITS */\n");
diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c
index 7295d150..27f5b666 100644
--- a/src/lisp/ao_lisp_mem.c
+++ b/src/lisp/ao_lisp_mem.c
@@ -17,11 +17,32 @@
#include "ao_lisp.h"
#include <stdio.h>
-uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4)));
-
#ifdef AO_LISP_MAKE_CONST
#include <stdlib.h>
uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));
+#define ao_lisp_pool ao_lisp_const
+#undef AO_LISP_POOL
+#define AO_LISP_POOL AO_LISP_POOL_CONST
+#else
+uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4)));
+#endif
+
+#if 0
+#define DBG_DUMP
+#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool))
+#define DBG(...) printf(__VA_ARGS__)
+static int move_dump;
+static int move_depth;
+#define DBG_RESET() (move_depth = 0)
+#define DBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0)
+#define DBG_MOVE_IN() (move_depth++)
+#define DBG_MOVE_OUT() (move_depth--)
+#else
+#define DBG(...)
+#define DBG_RESET()
+#define DBG_MOVE(...)
+#define DBG_MOVE_IN()
+#define DBG_MOVE_OUT()
#endif
uint8_t ao_lisp_exception;
@@ -112,6 +133,23 @@ clear_object(uint8_t *tag, void *addr, int size) {
return 0;
}
+static int
+busy_object(uint8_t *tag, void *addr) {
+ int base;
+
+ if (!addr)
+ return 1;
+
+ if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr)
+ return 1;
+
+ base = (uint8_t *) addr - ao_lisp_pool;
+ base = limit(base);
+ if (busy(tag, base))
+ return 1;
+ return 0;
+}
+
static void *move_old, *move_new;
static int move_size;
@@ -120,53 +158,96 @@ move_object(void)
{
int i;
+ DBG_RESET();
+ DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new));
+ DBG_MOVE_IN();
memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving));
for (i = 0; i < AO_LISP_ROOT; i++)
- if (ao_lisp_root[i].addr) {
+ if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) {
void *new;
+ DBG_MOVE("root %d\n", DBG_OFFSET(*ao_lisp_root[i].addr));
new = ao_lisp_move(ao_lisp_root[i].type, *ao_lisp_root[i].addr);
if (new)
*ao_lisp_root[i].addr = new;
}
+ DBG_MOVE_OUT();
+ DBG_MOVE("move done\n");
}
+#ifdef DBG_DUMP
static void
-collect(void)
+dump_busy(void)
+{
+ int i;
+ printf("busy:");
+ for (i = 0; i < ao_lisp_top; i += 4) {
+ if ((i & 0xff) == 0)
+ printf("\n");
+ else if ((i & 0x1f) == 0)
+ printf(" ");
+ if (busy(ao_lisp_busy, i))
+ putchar('*');
+ else
+ putchar('-');
+ }
+ printf ("\n");
+}
+#define DUMP_BUSY() dump_busy()
+#else
+#define DUMP_BUSY()
+#endif
+
+void
+ao_lisp_collect(void)
{
int i;
+ int top;
/* Mark */
memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy));
+ DBG("mark\n");
for (i = 0; i < AO_LISP_ROOT; i++)
- if (ao_lisp_root[i].addr)
+ if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) {
+ DBG("root %p\n", *ao_lisp_root[i].addr);
ao_lisp_mark(ao_lisp_root[i].type, *ao_lisp_root[i].addr);
+ }
+ DUMP_BUSY();
/* Compact */
- ao_lisp_top = 0;
- for (i = 0; i < AO_LISP_POOL; i += 4) {
+ DBG("find first busy\n");
+ for (i = 0; i < ao_lisp_top; i += 4) {
if (!busy(ao_lisp_busy, i))
break;
}
- ao_lisp_top = i;
- while(i < AO_LISP_POOL) {
+ top = i;
+ while(i < ao_lisp_top) {
if (busy(ao_lisp_busy, i)) {
+ DBG("busy %d -> %d\n", i, top);
move_old = &ao_lisp_pool[i];
- move_new = &ao_lisp_pool[ao_lisp_top];
+ move_new = &ao_lisp_pool[top];
move_size = 0;
move_object();
+ DBG("\tbusy size %d\n", move_size);
+ if (move_size == 0)
+ abort();
clear_object(ao_lisp_busy, move_old, move_size);
+ mark_object(ao_lisp_busy, move_new, move_size);
i += move_size;
- ao_lisp_top += move_size;
+ top += move_size;
+ DUMP_BUSY();
} else {
i += 4;
}
}
+ ao_lisp_top = top;
}
void
ao_lisp_mark(const struct ao_lisp_type *type, void *addr)
{
+ if (!addr)
+ return;
if (mark_object(ao_lisp_busy, addr, type->size(addr)))
return;
type->mark(addr);
@@ -178,12 +259,32 @@ ao_lisp_mark_memory(void *addr, int size)
return mark_object(ao_lisp_busy, addr, size);
}
+/*
+ * After the object has been moved, we have to reference it
+ * in the new location. This is only relevant for ao_lisp_poly_move
+ * as it needs to fetch the type byte from the object, which
+ * may have been overwritten by the copy
+ */
+void *
+ao_lisp_move_map(void *addr)
+{
+ if (addr == move_old) {
+ if (busy_object(ao_lisp_moving, addr))
+ return move_new;
+ }
+ return addr;
+}
+
static void *
check_move(void *addr, int size)
{
if (addr == move_old) {
- memmove(move_new, move_old, size);
- move_size = (size + 3) & ~3;
+ DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new));
+ if (!busy_object(ao_lisp_moving, addr)) {
+ DBG_MOVE(" copy %d\n", size);
+ memmove(move_new, move_old, size);
+ move_size = (size + 3) & ~3;
+ }
addr = move_new;
}
return addr;
@@ -192,15 +293,32 @@ check_move(void *addr, int size)
void *
ao_lisp_move(const struct ao_lisp_type *type, void *addr)
{
+ uint8_t *a = addr;
int size = type->size(addr);
if (!addr)
return NULL;
+#ifndef AO_LISP_MAKE_CONST
+ if (AO_LISP_IS_CONST(addr))
+ return addr;
+#endif
+ DBG_MOVE("object %d\n", DBG_OFFSET(addr));
+ if (a < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= a)
+ abort();
+ DBG_MOVE_IN();
addr = check_move(addr, size);
- if (mark_object(ao_lisp_moving, addr, size))
+ if (mark_object(ao_lisp_moving, addr, size)) {
+ DBG_MOVE("already moved\n");
+ DBG_MOVE_OUT();
return addr;
+ }
+ DBG_MOVE_OUT();
+ DBG_MOVE("recursing...\n");
+ DBG_MOVE_IN();
type->move(addr);
+ DBG_MOVE_OUT();
+ DBG_MOVE("done %d\n", DBG_OFFSET(addr));
return addr;
}
@@ -210,9 +328,15 @@ ao_lisp_move_memory(void *addr, int size)
if (!addr)
return NULL;
+ DBG_MOVE("memory %d\n", DBG_OFFSET(addr));
+ DBG_MOVE_IN();
addr = check_move(addr, size);
- if (mark_object(ao_lisp_moving, addr, size))
- return NULL;
+ if (mark_object(ao_lisp_moving, addr, size)) {
+ DBG_MOVE("already moved\n");
+ DBG_MOVE_OUT();
+ return addr;
+ }
+ DBG_MOVE_OUT();
return addr;
}
@@ -222,22 +346,14 @@ ao_lisp_alloc(int size)
void *addr;
size = ao_lisp_mem_round(size);
-#ifdef AO_LISP_MAKE_CONST
- if (ao_lisp_top + size > AO_LISP_POOL_CONST) {
- fprintf(stderr, "Too much constant data, increase AO_LISP_POOL_CONST\n");
- exit(1);
- }
- addr = ao_lisp_const + ao_lisp_top;
-#else
if (ao_lisp_top + size > AO_LISP_POOL) {
- collect();
+ ao_lisp_collect();
if (ao_lisp_top + size > AO_LISP_POOL) {
ao_lisp_exception |= AO_LISP_OOM;
return NULL;
}
}
addr = ao_lisp_pool + ao_lisp_top;
-#endif
ao_lisp_top += size;
return addr;
}
@@ -246,6 +362,7 @@ int
ao_lisp_root_add(const struct ao_lisp_type *type, void *addr)
{
int i;
+ DBG("add root type %p addr %p\n", type, addr);
for (i = 0; i < AO_LISP_ROOT; i++) {
if (!ao_lisp_root[i].addr) {
ao_lisp_root[i].addr = addr;
@@ -253,6 +370,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr)
return 1;
}
}
+ abort();
return 0;
}
diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c
index 38dcb961..e9367553 100644
--- a/src/lisp/ao_lisp_prim.c
+++ b/src/lisp/ao_lisp_prim.c
@@ -31,35 +31,32 @@ ao_lisp_poly_print(ao_poly p)
return p;
}
+static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = {
+ [AO_LISP_CONS] = &ao_lisp_cons_type,
+ [AO_LISP_STRING] = &ao_lisp_string_type,
+ [AO_LISP_ATOM] = &ao_lisp_atom_type,
+ [AO_LISP_BUILTIN] = &ao_lisp_builtin_type,
+};
+
void
ao_lisp_poly_mark(ao_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;
- }
+ const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)];
+ if (lisp_type)
+ ao_lisp_mark(lisp_type, ao_lisp_ref(p));
}
ao_poly
ao_lisp_poly_move(ao_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;
- }
+ uint8_t type = p & AO_LISP_TYPE_MASK;
+ const struct ao_lisp_type *lisp_type;
+
+ if (type == AO_LISP_OTHER)
+ type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p)));
+
+ lisp_type = ao_lisp_types[type];
+ if (lisp_type)
+ p = ao_lisp_poly(ao_lisp_move(lisp_type, ao_lisp_ref(p)), p & AO_LISP_TYPE_MASK);
return p;
}
diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c
index 8fc134e5..bc1eb36b 100644
--- a/src/lisp/ao_lisp_read.c
+++ b/src/lisp/ao_lisp_read.c
@@ -188,8 +188,6 @@ lex_quoted (void)
int count;
c = lex_get();
-// if (jumping)
-// return nil;
if (c == EOF)
return EOF;
c &= 0x7f;
@@ -218,8 +216,6 @@ lex_quoted (void)
count = 1;
while (count <= 3) {
c = lex_get();
-// if (jumping)
-// return nil;
if (c == EOF)
return EOF;
c &= 0x7f;
@@ -288,11 +284,17 @@ lex(void)
if (lex_class & ENDOFFILE)
return AO_LISP_NIL;
-// if (jumping)
-// return nil;
if (lex_class & WHITE)
continue;
+ if (lex_class & COMMENT) {
+ while ((c = lexc()) != '\n') {
+ if (lex_class & ENDOFFILE)
+ return AO_LISP_NIL;
+ }
+ continue;
+ }
+
if (lex_class & (BRA|KET|QUOTEC)) {
add_token(c);
end_token();
@@ -312,8 +314,6 @@ lex(void)
if (lex_class & STRINGC) {
for (;;) {
c = lexc();
-// if (jumping)
-// return nil;
if (lex_class & (STRINGC|ENDOFFILE)) {
end_token();
return STRING;
@@ -349,8 +349,6 @@ lex(void)
}
add_token (c);
c = lexc ();
-// if (jumping)
-// return nil;
if (lex_class & (NOTNAME)) {
// if (lex_class & ENDOFFILE)
// clearerr (f);
@@ -403,6 +401,10 @@ pop_read_stack(int cons)
read_cons_tail && read_cons_tail->cdr;
read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr))
;
+ } else {
+ read_cons = 0;
+ read_cons_tail = 0;
+ read_stack = 0;
}
return in_quote;
}
@@ -420,6 +422,7 @@ ao_lisp_read(void)
ao_lisp_root_add(&ao_lisp_cons_type, &read_cons);
ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail);
ao_lisp_root_add(&ao_lisp_cons_type, &read_stack);
+ been_here = 1;
}
parse_token = lex();
diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile
index 0df44317..1b7e0bb0 100644
--- a/src/nucleao-32/Makefile
+++ b/src/nucleao-32/Makefile
@@ -13,6 +13,8 @@ INC = \
ao_pins.h \
ao_product.h \
ao_task.h \
+ ao_lisp.h \
+ ao_lisp_const.h \
stm32f0.h \
Makefile
@@ -43,6 +45,7 @@ ALTOS_SRC = \
ao_lisp_builtin.c \
ao_lisp_read.c \
ao_lisp_rep.c \
+ ao_lisp_frame.c \
ao_exti_stm.c
PRODUCT=Nucleo-32
diff --git a/src/test/Makefile b/src/test/Makefile
index 6c51c421..bd195161 100644
--- a/src/test/Makefile
+++ b/src/test/Makefile
@@ -91,7 +91,9 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h
#AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o
-AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o
+AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \
+ ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \
+ ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o
ao_lisp_test: $(AO_LISP_OBJS)
cc $(CFLAGS) -o $@ $(AO_LISP_OBJS)
diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c
index 810a1528..e303869f 100644
--- a/src/test/ao_lisp_test.c
+++ b/src/test/ao_lisp_test.c
@@ -36,7 +36,6 @@ main (int argc, char **argv)
list = ao_lisp_cons_cons(ao_lisp_string_poly(string), list);
list = ao_lisp_cons_cons(ao_lisp_int_poly(i), list);
atom = ao_lisp_atom_intern("ant");
- atom->val = ao_lisp_cons_poly(list);
list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list);
}
ao_lisp_poly_print(ao_lisp_cons_poly(list));
@@ -45,7 +44,7 @@ main (int argc, char **argv)
for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) {
printf("%s = ", atom->name);
- ao_lisp_poly_print(atom->val);
+ ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom)));
printf("\n");
}
#if 1
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 04:10:16 +0000