ao_lisp_prim.c \
ao_lisp_builtin.c \
ao_lisp_read.c \
- ao_lisp_frame.c
+ ao_lisp_frame.c \
+ ao_lisp_error.c
OBJS=$(SRCS:.c=.o)
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"))
+
+#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n))
+
+#define _ao_lisp_atom_quote _atom("quote")
+#define _ao_lisp_atom_set _atom("set")
+#define _ao_lisp_atom_setq _atom("setq")
+#define _ao_lisp_atom_t _atom("t")
+#define _ao_lisp_atom_car _atom("car")
+#define _ao_lisp_atom_cdr _atom("cdr")
+#define _ao_lisp_atom_cons _atom("cons")
+#define _ao_lisp_atom_cond _atom("cond")
#else
#include "ao_lisp_const.h"
+#ifndef AO_LISP_POOL
#define AO_LISP_POOL 1024
+#endif
extern uint8_t ao_lisp_pool[AO_LISP_POOL];
#endif
extern uint8_t ao_lisp_exception;
typedef uint16_t ao_poly;
+typedef int16_t ao_signed_poly;
static inline int
ao_lisp_is_const(ao_poly poly) {
builtin_quote,
builtin_set,
builtin_setq,
+ builtin_cond,
builtin_print,
builtin_plus,
builtin_minus,
static inline int
ao_lisp_poly_int(ao_poly poly)
{
- return (int) poly >> AO_LISP_TYPE_SHIFT;
+ return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT);
}
static inline ao_poly
ao_lisp_int_poly(int i)
{
- return ((ao_poly) i << 2) + AO_LISP_INT;
+ return ((ao_poly) i << 2) | AO_LISP_INT;
}
static inline char *
extern struct ao_lisp_atom *ao_lisp_atoms;
-void
-ao_lisp_atom_init(void);
+extern struct ao_lisp_frame *ao_lisp_frame_current;
void
ao_lisp_atom_print(ao_poly a);
ao_poly
ao_lisp_eval(ao_poly p);
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *cons);
+
/* builtin */
void
ao_lisp_builtin_print(ao_poly b);
extern const struct ao_lisp_type ao_lisp_builtin_type;
+/* Check argument count */
+ao_poly
+ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max);
+
+/* Check argument type */
+ao_poly
+ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok);
+
+/* Fetch an arg (nil if off the end) */
+ao_poly
+ao_lisp_arg(struct ao_lisp_cons *cons, int argc);
+
/* read */
ao_poly
ao_lisp_read(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);
+ao_poly *
+ao_lisp_frame_ref(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);
+/* error */
+
+ao_poly
+ao_lisp_error(int error, char *format, ...);
+
#endif /* _AO_LISP_H_ */
return atom;
}
-static struct ao_lisp_frame *globals;
+static struct ao_lisp_frame *ao_lisp_frame_global;
+struct ao_lisp_frame *ao_lisp_frame_current;
+
+static void
+ao_lisp_atom_init(void)
+{
+ if (!ao_lisp_frame_global) {
+ ao_lisp_frame_global = ao_lisp_frame_new(0, 0);
+ ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global);
+ ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current);
+ }
+}
+
+static ao_poly *
+ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom)
+{
+ ao_poly *ref;
+ ao_lisp_atom_init();
+ while (frame) {
+ ref = ao_lisp_frame_ref(frame, atom);
+ if (ref)
+ return ref;
+ frame = ao_lisp_poly_frame(frame->next);
+ }
+ if (ao_lisp_frame_global) {
+ ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
+ if (ref)
+ return ref;
+ }
+ return NULL;
+}
ao_poly
ao_lisp_atom_get(ao_poly atom)
{
- struct ao_lisp_frame *frame = globals;
+ ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+
+ if (!ref && ao_lisp_frame_global)
+ ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
#ifdef ao_builtin_frame
- if (!frame)
- frame = ao_lisp_poly_frame(ao_builtin_frame);
+ if (!ref)
+ ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom);
#endif
- return ao_lisp_frame_get(frame, atom);
+ if (ref)
+ return *ref;
+ return AO_LISP_NIL;
}
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
- }
- }
+ ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+
+ if (!ref && ao_lisp_frame_global)
+ ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
+ if (ref)
+ *ref = val;
+ else
+ ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val);
return val;
}
printf("[builtin]");
}
-static int check_argc(struct ao_lisp_cons *cons, int min, int max)
+ao_poly
+ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max)
{
int argc = 0;
argc++;
cons = ao_lisp_poly_cons(cons->cdr);
}
- if (argc < min || argc > max) {
- ao_lisp_exception |= AO_LISP_INVALID;
- return 0;
- }
- return 1;
+ if (argc < min || argc > max)
+ return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name);
+ return _ao_lisp_atom_t;
}
-static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
+ao_poly
+ao_lisp_arg(struct ao_lisp_cons *cons, int argc)
{
- ao_poly car;
-
- /* find the desired arg */
- while (argc--)
+ while (argc--) {
+ if (!cons)
+ return AO_LISP_NIL;
cons = ao_lisp_poly_cons(cons->cdr);
- car = cons->car;
- if ((!car && !nil_ok) ||
- ao_lisp_poly_type(car) != type)
- {
- ao_lisp_exception |= AO_LISP_INVALID;
- return 0;
}
- return 1;
+ return cons->car;
+}
+
+ao_poly
+ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
+{
+ ao_poly car = ao_lisp_arg(cons, argc);
+
+ if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type)
+ return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc);
+ return _ao_lisp_atom_t;
}
enum math_op { math_plus, math_minus, math_times, math_divide, math_mod };
ao_poly
ao_lisp_car(struct ao_lisp_cons *cons)
{
- if (!check_argc(cons, 1, 1))
+ if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1))
return AO_LISP_NIL;
- if (!check_argt(cons, 0, AO_LISP_CONS, 0)) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0))
return AO_LISP_NIL;
- }
return ao_lisp_poly_cons(cons->car)->car;
}
ao_poly
ao_lisp_cdr(struct ao_lisp_cons *cons)
{
- if (!cons) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1))
return AO_LISP_NIL;
- }
- if (!cons->car) {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
- }
- if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0))
return AO_LISP_NIL;
- }
return ao_lisp_poly_cons(cons->car)->cdr;
}
ao_lisp_cons(struct ao_lisp_cons *cons)
{
ao_poly car, cdr;
- if (!cons) {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
- }
- car = cons->car;
- cdr = cons->cdr;
- if (!car || !cdr) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2))
return AO_LISP_NIL;
- }
- cdr = ao_lisp_poly_cons(cdr)->car;
- if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1))
return AO_LISP_NIL;
- }
+ car = ao_lisp_arg(cons, 0);
+ cdr = ao_lisp_arg(cons, 1);
return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr)));
}
ao_poly
ao_lisp_quote(struct ao_lisp_cons *cons)
{
- if (!cons) {
- ao_lisp_exception |= AO_LISP_INVALID;
+ if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1))
return AO_LISP_NIL;
- }
- return cons->car;
+ return ao_lisp_arg(cons, 0);
}
ao_poly
ao_lisp_set(struct ao_lisp_cons *cons)
{
- if (!check_argc(cons, 2, 2))
+ if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2))
return AO_LISP_NIL;
- if (!check_argt(cons, 0, AO_LISP_ATOM, 0))
+ if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0))
return AO_LISP_NIL;
- return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car);
+ return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_poly_cons(ao_lisp_arg(cons, 1))->car);
}
ao_poly
ao_lisp_setq(struct ao_lisp_cons *cons)
{
struct ao_lisp_cons *expand = 0;
- if (!check_argc(cons, 2, 2))
+ if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2))
return AO_LISP_NIL;
expand = ao_lisp_cons_cons(_ao_lisp_atom_set,
ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote,
return ao_lisp_cons_poly(expand);
}
+ao_poly
+ao_lisp_cond(struct ao_lisp_cons *cons)
+{
+ int argc;
+ struct ao_lisp_cons *arg;
+
+ argc = 0;
+ for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) {
+ if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS)
+ return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d",
+ ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc);
+ }
+ ao_lisp_set_cond(cons);
+ return AO_LISP_NIL;
+}
+
ao_poly
ao_lisp_print(struct ao_lisp_cons *cons)
{
r *= c;
break;
case math_divide:
- if (c == 0) {
- ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
- return AO_LISP_NIL;
- }
+ if (c == 0)
+ return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
r /= c;
break;
case math_mod:
- if (c == 0) {
- ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
- return AO_LISP_NIL;
- }
+ if (c == 0)
+ return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero");
r %= c;
break;
}
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 {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
- }
+ else
+ return ao_lisp_error(AO_LISP_INVALID, "invalid args");
}
return ret;
}
[builtin_quote] = ao_lisp_quote,
[builtin_set] = ao_lisp_set,
[builtin_setq] = ao_lisp_setq,
+ [builtin_cond] = ao_lisp_cond,
[builtin_print] = ao_lisp_print,
[builtin_plus] = ao_lisp_plus,
[builtin_minus] = ao_lisp_minus,
cadr (lambda (l) (car (cdr l)))
+list (lexpr (l) l)
+1+ (lambda (x) (+ x 1))
+1- (lambda (x) (- x 1))
--- /dev/null
+/*
+ * 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 <stdarg.h>
+
+ao_poly
+ao_lisp_error(int error, char *format, ...)
+{
+ va_list args;
+
+ ao_lisp_exception |= error;
+ va_start(args, format);
+ vprintf(format, args);
+ va_end(args);
+ printf("\n");
+ return AO_LISP_NIL;
+}
#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;
-
#if 0
#define DBG(...) printf(__VA_ARGS__)
-#define DBG_CONS(a) ao_lisp_cons_print(a)
+#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a))
#define DBG_POLY(a) ao_lisp_poly_print(a)
+#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
#else
#define DBG(...)
#define DBG_CONS(a)
#define DBG_POLY(a)
#endif
+struct ao_lisp_stack {
+ ao_poly next;
+ ao_poly actuals;
+ ao_poly formals;
+ ao_poly frame;
+ ao_poly cond;
+};
+
+static struct ao_lisp_stack *
+ao_lisp_poly_stack(ao_poly p)
+{
+ return ao_lisp_ref(p);
+}
+
+static ao_poly
+ao_lisp_stack_poly(struct ao_lisp_stack *stack)
+{
+ return ao_lisp_poly(stack, AO_LISP_OTHER);
+}
+
+static int
+stack_size(void *addr)
+{
+ (void) addr;
+ return sizeof (struct ao_lisp_stack);
+}
+
+static void
+stack_mark(void *addr)
+{
+ struct ao_lisp_stack *stack = addr;
+ for (;;) {
+ ao_lisp_poly_mark(stack->actuals);
+ ao_lisp_poly_mark(stack->formals);
+ ao_lisp_poly_mark(stack->frame);
+ ao_lisp_poly_mark(stack->cond);
+ stack = ao_lisp_poly_stack(stack->next);
+ if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
+ break;
+ }
+}
+
+static void
+stack_move(void *addr)
+{
+ struct ao_lisp_stack *stack = addr;
+
+ for (;;) {
+ struct ao_lisp_stack *next;
+ stack->actuals = ao_lisp_poly_move(stack->actuals);
+ stack->formals = ao_lisp_poly_move(stack->formals);
+ stack->frame = ao_lisp_poly_move(stack->frame);
+ stack->cond = ao_lisp_poly_move(stack->cond);
+ next = ao_lisp_ref(stack->next);
+ next = ao_lisp_move_memory(next, sizeof (struct ao_lisp_stack));
+ stack->next = ao_lisp_stack_poly(next);
+ stack = next;
+ }
+}
+
+static const struct ao_lisp_type ao_lisp_stack_type = {
+ .size = stack_size,
+ .mark = stack_mark,
+ .move = stack_move
+};
+
+
+static struct ao_lisp_stack *stack;
+static struct ao_lisp_cons *actuals;
+static struct ao_lisp_cons *formals;
+static struct ao_lisp_cons *formals_tail;
+static struct ao_lisp_cons *cond;
+struct ao_lisp_frame *next_frame;
+static uint8_t been_here;
+
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *c)
+{
+ cond = c;
+ return AO_LISP_NIL;
+}
+
+static int
+ao_lisp_stack_push(void)
+{
+ struct ao_lisp_stack *n = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
+ if (!n)
+ return 0;
+ n->next = ao_lisp_stack_poly(stack);
+ n->actuals = ao_lisp_cons_poly(actuals);
+ n->formals = ao_lisp_cons_poly(formals);
+ n->cond = ao_lisp_cons_poly(cond);
+ n->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
+ DBG("push frame %d\n", OFFSET(ao_lisp_frame_current));
+ stack = n;
+ return 1;
+}
+
+static void
+ao_lisp_stack_pop(void)
+{
+ actuals = ao_lisp_poly_cons(stack->actuals);
+ formals = ao_lisp_poly_cons(stack->formals);
+ cond = ao_lisp_poly_cons(stack->cond);
+ ao_lisp_frame_current = ao_lisp_poly_frame(stack->frame);
+ DBG("pop frame %d\n", OFFSET(ao_lisp_frame_current));
+ formals_tail = 0;
+
+ /* Recompute the tail of the formals list */
+ if (formals) {
+ struct ao_lisp_cons *formal;
+ for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr));
+ formals_tail = formal;
+ }
+ stack = ao_lisp_poly_stack(stack->next);
+}
+
+static void
+ao_lisp_stack_clear(void)
+{
+ stack = 0;
+ actuals = formals = formals_tail = 0;
+ cond = 0;
+ ao_lisp_frame_current = 0;
+}
+
+
+static ao_poly
+func_type(ao_poly func)
+{
+ struct ao_lisp_cons *cons;
+ struct ao_lisp_cons *args;
+ int f;
+
+ DBG("func type "); DBG_POLY(func); DBG("\n");
+ if (func == AO_LISP_NIL)
+ return ao_lisp_error(AO_LISP_INVALID, "func is nil");
+ if (ao_lisp_poly_type(func) != AO_LISP_CONS)
+ return ao_lisp_error(AO_LISP_INVALID, "func is not list");
+ cons = ao_lisp_poly_cons(func);
+ if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
+ return AO_LISP_NIL;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
+ return AO_LISP_NIL;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
+ return AO_LISP_NIL;
+ args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
+ f = 0;
+ while (args) {
+ if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
+ return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
+ }
+ args = ao_lisp_poly_cons(args->cdr);
+ f++;
+ }
+ return ao_lisp_arg(cons, 0);
+}
+
+static int
+ao_lisp_cons_length(struct ao_lisp_cons *cons)
+{
+ int len = 0;
+ while (cons) {
+ len++;
+ cons = ao_lisp_poly_cons(cons->cdr);
+ }
+ return len;
+}
+
+static ao_poly
+ao_lisp_lambda(struct ao_lisp_cons *cons)
+{
+ ao_poly type;
+ struct ao_lisp_cons *lambda;
+ struct ao_lisp_cons *args;
+ int args_wanted;
+ int args_provided;
+
+ lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
+ DBG("lambda "); DBG_CONS(lambda); DBG("\n");
+ type = ao_lisp_arg(lambda, 0);
+ args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
+
+ args_wanted = ao_lisp_cons_length(args);
+
+ /* Create a frame to hold the variables
+ */
+ if (type == _ao_lisp_atom_lambda)
+ args_provided = ao_lisp_cons_length(cons) - 1;
+ else
+ args_provided = 1;
+ if (args_wanted != args_provided)
+ return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
+ next_frame = ao_lisp_frame_new(args_wanted, 0);
+ DBG("new frame %d\n", OFFSET(next_frame));
+ switch (type) {
+ case _ao_lisp_atom_lambda: {
+ int f;
+ struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr);
+
+ for (f = 0; f < args_wanted; f++) {
+ next_frame->vals[f].atom = args->car;
+ next_frame->vals[f].val = vals->car;
+ args = ao_lisp_poly_cons(args->cdr);
+ vals = ao_lisp_poly_cons(vals->cdr);
+ }
+ break;
+ }
+ case _ao_lisp_atom_lexpr:
+ case _ao_lisp_atom_nlambda:
+ next_frame->vals[0].atom = args->car;
+ next_frame->vals[0].val = cons->cdr;
+ break;
+ case _ao_lisp_atom_macro:
+ next_frame->vals[0].atom = args->car;
+ next_frame->vals[0].val = ao_lisp_cons_poly(cons);
+ break;
+ }
+ return ao_lisp_arg(lambda, 2);
+}
+
ao_poly
ao_lisp_eval(ao_poly v)
{
if (!been_here) {
been_here = 1;
- ao_lisp_root_add(&ao_lisp_cons_type, &stack);
+ ao_lisp_root_add(&ao_lisp_stack_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);
actuals = 0;
formals = 0;
formals_tail = 0;
+ cond = 0;
for (;;) {
restart:
+ if (cond) {
+ if (cond->car == AO_LISP_NIL) {
+ cond = AO_LISP_NIL;
+ v = AO_LISP_NIL;
+ } else {
+ if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) {
+ ao_lisp_error(AO_LISP_INVALID, "malformed cond");
+ goto bail;
+ }
+ v = ao_lisp_poly_cons(cond->car)->car;
+ }
+ }
+
/* 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;
+ /* Push existing bits on the stack */
+ if (cons++)
+ if (!ao_lisp_stack_push())
+ goto bail;
- frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals);
- stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack);
- }
actuals = ao_lisp_poly_cons(v);
formals = NULL;
formals_tail = NULL;
+ cond = NULL;
+
v = actuals->car;
- DBG("start: stack"); DBG_CONS(stack); DBG("\n");
- DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
- DBG("start: formals"); DBG_CONS(formals); DBG("\n");
+// DBG("start: stack"); DBG_CONS(stack); DBG("\n");
+// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
+// DBG("start: formals"); DBG_CONS(formals); DBG("\n");
}
/* Evaluate primitive types */
break;
}
- if (!cons)
- break;
-
- for (;;) {
+ while (cons) {
DBG("add formal: "); DBG_POLY(v); DBG("\n");
+ /* We've processed the first element of the list, go check
+ * what kind of function we've got
+ */
if (formals == NULL) {
if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
switch (b->args) {
case AO_LISP_NLAMBDA:
- v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
- goto done_eval;
+ formals = actuals;
+ goto eval;
case AO_LISP_MACRO:
v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
DBG(" -> "); DBG_POLY(v);
DBG("\n");
if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
- ao_lisp_exception |= AO_LISP_INVALID;
- return AO_LISP_NIL;
+ ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
+ goto bail;
}
-
/* Reset frame to the new list */
actuals = ao_lisp_poly_cons(v);
v = actuals->car;
goto restart;
}
+ } else {
+ switch (func_type(v)) {
+ case _ao_lisp_atom_lambda:
+ case _ao_lisp_atom_lexpr:
+ break;
+ case _ao_lisp_atom_nlambda:
+ formals = actuals;
+ goto eval;
+ case _ao_lisp_atom_macro:
+ break;
+ default:
+ ao_lisp_error(AO_LISP_INVALID, "operator is not a function");
+ goto bail;
+ }
}
}
v = formals->car;
+ eval:
+
/* Evaluate the resulting list */
if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
DBG(" -> ");
DBG_POLY(v);
DBG ("\n");
+ if (ao_lisp_exception)
+ goto bail;
+
+ if (cond)
+ goto restart;
} else {
- ao_lisp_exception |= AO_LISP_INVALID;
+ v = ao_lisp_lambda(formals);
+ if (ao_lisp_exception)
+ goto bail;
}
- if (ao_lisp_exception)
- return AO_LISP_NIL;
- done_eval:
- 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 = ao_lisp_poly_cons(frame->cdr);
- formals_tail = NULL;
-
- /* Recompute the tail of the formals list */
- if (formals) {
- for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr));
- formals_tail = formal;
- }
- stack = ao_lisp_poly_cons(stack->cdr);
- DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
- DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
- DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
+ --cons;
+ if (cons) {
+ ao_lisp_stack_pop();
+// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
+// 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;
+ ao_lisp_frame_current = 0;
+ }
+ if (next_frame) {
+ ao_lisp_frame_current = next_frame;
+ DBG("next frame %d\n", OFFSET(next_frame));
+ next_frame = 0;
+ goto restart;
+ }
+ if (cond) {
+ if (v) {
+ v = ao_lisp_poly_cons(cond->car)->cdr;
+ if (v != AO_LISP_NIL) {
+ v = ao_lisp_poly_cons(v)->car;
+ goto restart;
+ }
+ } else {
+ cond = ao_lisp_poly_cons(cond->cdr);
+ goto restart;
+ }
}
}
if (!cons)
break;
}
+ DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current));
return v;
+bail:
+ ao_lisp_stack_clear();
+ return AO_LISP_NIL;
}
.move = frame_move
};
-static ao_poly *
+ao_poly *
ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom)
{
int f;
"quote", AO_LISP_NLAMBDA,builtin_quote,
"set", AO_LISP_LEXPR, builtin_set,
"setq", AO_LISP_MACRO, builtin_setq,
+ "cond", AO_LISP_NLAMBDA,builtin_cond,
"print", AO_LISP_LEXPR, builtin_print,
"+", AO_LISP_LEXPR, builtin_plus,
"-", AO_LISP_LEXPR, builtin_minus,
"%", AO_LISP_LEXPR, builtin_mod
};
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *c)
+{
+ (void) c;
+ return AO_LISP_NIL;
+}
+
#define N_FUNC (sizeof funcs / sizeof funcs[0])
+/* Syntactic atoms */
+char *atoms[] = {
+ "lambda",
+ "nlambda",
+ "lexpr",
+ "macro"
+};
+
+#define N_ATOM (sizeof atoms / sizeof atoms[0])
+
struct ao_lisp_frame *globals;
static int
int
main(int argc, char **argv)
{
- int f, o;
+ int f, o, i;
ao_poly atom, val;
struct ao_lisp_atom *a;
+ struct ao_lisp_builtin *b;
int in_atom;
printf("/*\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);
+ b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args);
+ a = ao_lisp_atom_intern(funcs[f].name);
globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b));
}
+ /* atoms for syntax */
+ for (i = 0; i < N_ATOM; i++)
+ (void) ao_lisp_atom_intern(atoms[i]);
+
/* boolean constants */
a = ao_lisp_atom_intern("nil");
globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL);
// printf ("in: "); ao_lisp_poly_print(in); printf("\n");
out = ao_lisp_eval(in);
if (ao_lisp_exception) {
- if (ao_lisp_exception & AO_LISP_OOM)
- printf("out of memory\n");
- if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO)
- printf("divide by zero\n");
- if (ao_lisp_exception & AO_LISP_INVALID)
- printf("invalid operation\n");
ao_lisp_exception = 0;
} else {
ao_lisp_poly_print(out);
ao_lisp_read.c \
ao_lisp_rep.c \
ao_lisp_frame.c \
+ ao_lisp_error.c \
ao_exti_stm.c
PRODUCT=Nucleo-32
#define LED_PIN_GREEN 3
#define AO_LED_GREEN (1 << LED_PIN_GREEN)
#define AO_LED_PANIC AO_LED_GREEN
+#define AO_CMD_LEN 128
+#define AO_LISP_POOL 2048
#define LEDS_AVAILABLE (AO_LED_GREEN)
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_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \
+ ao_lisp_error.o
ao_lisp_test: $(AO_LISP_OBJS)
cc $(CFLAGS) -o $@ $(AO_LISP_OBJS)
#include "ao_lisp.h"
#include <stdio.h>
+#if 0
static struct ao_lisp_cons *list;
static char *string;
+#endif
int
main (int argc, char **argv)
{
+#if 0
int i, j;
- struct ao_lisp_atom *atom;
+ struct ao_lisp_atom *atom;
ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list);
ao_lisp_root_add(&ao_lisp_string_type, (void **) &string);
ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom)));
printf("\n");
}
-#if 1
+#endif
+#if 0
list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")),
ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")),
ao_lisp_cons_cons(ao_lisp_int_poly(3),
printf ("\n");
ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list)));
printf ("\n");
-
+#endif
+#if 1
ao_lisp_read_eval_print();
#endif
}
projects / fw / altos / commitdiff