#define AO_LISP_DIVIDE_BY_ZERO 0x02
#define AO_LISP_INVALID 0x04
#define AO_LISP_UNDEFINED 0x08
-#define AO_LISP_EOF 0x10
-#define AO_LISP_EXIT 0x20
+#define AO_LISP_REDEFINED 0x10
+#define AO_LISP_EOF 0x20
+#define AO_LISP_EXIT 0x40
extern uint8_t ao_lisp_exception;
ao_lisp_atom_intern(char *name);
ao_poly *
-ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom);
+ao_lisp_atom_ref(ao_poly atom);
ao_poly
ao_lisp_atom_get(ao_poly atom);
ao_poly
ao_lisp_atom_set(ao_poly atom, ao_poly val);
+ao_poly
+ao_lisp_atom_def(ao_poly atom, ao_poly val);
+
/* int */
void
ao_lisp_int_write(ao_poly i);
void
ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val);
-int
-ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val);
+ao_poly
+ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val);
void
ao_lisp_frame_write(ao_poly p);
+void
+ao_lisp_frame_init(void);
+
/* lambda */
extern const struct ao_lisp_type ao_lisp_lambda_type;
#include <assert.h>
extern int dbg_move_depth;
#define MDBG_DUMP 1
-#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool))
+#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1)
extern int dbg_mem;
return atom;
}
-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);
-}
-
ao_poly *
-ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom)
+ao_lisp_atom_ref(ao_poly atom)
{
ao_poly *ref;
- ao_lisp_atom_init();
- while (frame) {
+ struct ao_lisp_frame *frame;
+
+ for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) {
ref = ao_lisp_frame_ref(frame, atom);
if (ref)
return ref;
- frame = ao_lisp_poly_frame(frame->prev);
}
- if (ao_lisp_frame_global) {
- ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
- if (ref)
- return ref;
- }
- return NULL;
+ return ao_lisp_frame_ref(ao_lisp_frame_global, atom);
}
ao_poly
ao_lisp_atom_get(ao_poly atom)
{
- ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+ ao_poly *ref = ao_lisp_atom_ref(atom);
- if (!ref && ao_lisp_frame_global)
- ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
#ifdef ao_builtin_frame
if (!ref)
ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom);
ao_poly
ao_lisp_atom_set(ao_poly atom, ao_poly val)
{
- ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+ ao_poly *ref = ao_lisp_atom_ref(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_add(&ao_lisp_frame_global, atom, val);
+ if (!ref)
+ return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name);
+ *ref = val;
return val;
}
+ao_poly
+ao_lisp_atom_def(ao_poly atom, ao_poly val)
+{
+ ao_poly *ref = ao_lisp_atom_ref(atom);
+
+ if (ref) {
+ if (ao_lisp_frame_current)
+ return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name);
+ *ref = val;
+ return val;
+ }
+ return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val);
+}
+
void
ao_lisp_atom_write(ao_poly a)
{
return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1));
}
+ao_poly
+ao_lisp_do_def(struct ao_lisp_cons *cons)
+{
+ if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2))
+ return AO_LISP_NIL;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0))
+ return AO_LISP_NIL;
+
+ return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1));
+}
+
ao_poly
ao_lisp_do_setq(struct ao_lisp_cons *cons)
{
name = cons->car;
if (ao_lisp_poly_type(name) != AO_LISP_ATOM)
return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom");
- if (!ao_lisp_atom_ref(ao_lisp_frame_current, name))
+ if (!ao_lisp_atom_ref(name))
return ao_lisp_error(AO_LISP_INVALID, "atom not defined");
return ao_lisp__cons(_ao_lisp_atom_set,
ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote,
atom unquote_splicing unquote-splicing
f_lambda set
macro setq set!
+f_lambda def
nlambda cond
nlambda begin
nlambda while
; Lisp code placed in ROM
; return a list containing all of the arguments
-(set (quote list) (lexpr (l) l))
+(def (quote list) (lexpr (l) l))
-(set (quote set!)
+(def (quote def!)
(macro (name value rest)
(list
- set
- (list
- quote
- name)
+ def
+ (list quote name)
value)
)
)
-(set! append
- (lexpr (args)
- ((lambda (append-list append-lists)
- (set! append-list
- (lambda (a b)
- (cond ((null? a) b)
- (else (cons (car a) (append-list (cdr a) b)))
- )
- )
- )
- (set! append-lists
- (lambda (lists)
- (cond ((null? lists) lists)
- ((null? (cdr lists)) (car lists))
- (else (append-list (car lists) (append-lists (cdr lists))))
- )
- )
- )
- (append-lists args)
- ) () ())
- )
- )
+(begin
+ (def! append
+ (lexpr (args)
+ ((lambda (append-list append-lists)
+ (set! append-list
+ (lambda (a b)
+ (cond ((null? a) b)
+ (else (cons (car a) (append-list (cdr a) b)))
+ )
+ )
+ )
+ (set! append-lists
+ (lambda (lists)
+ (cond ((null? lists) lists)
+ ((null? (cdr lists)) (car lists))
+ (else (append-list (car lists) (append-lists (cdr lists))))
+ )
+ )
+ )
+ (append-lists args)
+ ) () ())
+ )
+ )
+ 'append)
(append '(a b c) '(d e f) '(g h i))
; boolean operators
-(set! or
- (macro (l)
- ((lambda (_or)
- (set! _or
- (lambda (l)
- (cond ((null? l) #f)
- ((null? (cdr l))
- (car l))
- (else
- (list
- cond
- (list
- (car l))
- (list
- 'else
- (_or (cdr l))
- )
- )
- )
- )
+(begin
+ (def! or
+ (macro (l)
+ (def! _or
+ (lambda (l)
+ (cond ((null? l) #f)
+ ((null? (cdr l))
+ (car l))
+ (else
+ (list
+ cond
+ (list
+ (car l))
+ (list
+ 'else
+ (_or (cdr l))
+ )
)
+ )
)
- (_or l)) ())))
+ )
+ )
+ (_or l)))
+ 'or)
; execute to resolve macros
(or #f #t)
-
-(set! and
- (macro (l)
- ((lambda (_and)
- (set! _and
- (lambda (l)
- (cond ((null? l) #t)
- ((null? (cdr l))
- (car l))
- (else
- (list
- cond
- (list
- (car l)
- (_and (cdr l))
- )
- )
- )
- )
+(begin
+ (def! and
+ (macro (l)
+ (def! _and
+ (lambda (l)
+ (cond ((null? l) #t)
+ ((null? (cdr l))
+ (car l))
+ (else
+ (list
+ cond
+ (list
+ (car l)
+ (_and (cdr l))
+ )
)
+ )
)
- (_and l)) ())
+ )
)
- )
-
+ (_and l)))
+ 'and)
; execute to resolve macros
(and #t #f)
-(set! quasiquote
- (macro (x rest)
- ((lambda (constant? combine-skeletons expand-quasiquote)
- (set! constant?
+(begin
+ (def! quasiquote
+ (macro (x rest)
+ (def! constant?
; A constant value is either a pair starting with quote,
; or anything which is neither a pair nor a symbol
- (lambda (exp)
- (cond ((pair? exp)
- (eq? (car exp) 'quote)
- )
- (else
- (not (symbol? exp))
- )
- )
- )
- )
- (set! combine-skeletons
- (lambda (left right exp)
- (cond
- ((and (constant? left) (constant? right))
- (cond ((and (eqv? (eval left) (car exp))
- (eqv? (eval right) (cdr exp)))
- (list 'quote exp)
- )
- (else
- (list 'quote (cons (eval left) (eval right)))
- )
- )
- )
- ((null? right)
- (list 'list left)
- )
- ((and (pair? right) (eq? (car right) 'list))
- (cons 'list (cons left (cdr right)))
+ (lambda (exp)
+ (cond ((pair? exp)
+ (eq? (car exp) 'quote)
)
(else
- (list 'cons left right)
+ (not (symbol? exp))
)
)
- )
- )
+ )
+ )
+ (def! combine-skeletons
+ (lambda (left right exp)
+ (cond
+ ((and (constant? left) (constant? right))
+ (cond ((and (eqv? (eval left) (car exp))
+ (eqv? (eval right) (cdr exp)))
+ (list 'quote exp)
+ )
+ (else
+ (list 'quote (cons (eval left) (eval right)))
+ )
+ )
+ )
+ ((null? right)
+ (list 'list left)
+ )
+ ((and (pair? right) (eq? (car right) 'list))
+ (cons 'list (cons left (cdr right)))
+ )
+ (else
+ (list 'cons left right)
+ )
+ )
+ )
+ )
- (set! expand-quasiquote
- (lambda (exp nesting)
- (cond
+ (def! expand-quasiquote
+ (lambda (exp nesting)
+ (cond
; non cons -- constants
; themselves, others are
; quoted
- ((not (pair? exp))
- (cond ((constant? exp)
- exp
- )
- (else
- (list 'quote exp)
- )
- )
- )
+ ((not (pair? exp))
+ (cond ((constant? exp)
+ exp
+ )
+ (else
+ (list 'quote exp)
+ )
+ )
+ )
; check for an unquote exp and
; add the param unquoted
- ((and (eq? (car exp) 'unquote) (= (length exp) 2))
- (cond ((= nesting 0)
- (car (cdr exp))
- )
- (else
- (combine-skeletons ''unquote
- (expand-quasiquote (cdr exp) (- nesting 1))
- exp))
- )
- )
+ ((and (eq? (car exp) 'unquote) (= (length exp) 2))
+ (cond ((= nesting 0)
+ (car (cdr exp))
+ )
+ (else
+ (combine-skeletons ''unquote
+ (expand-quasiquote (cdr exp) (- nesting 1))
+ exp))
+ )
+ )
; nested quasi-quote --
; construct the right
; expression
- ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
- (combine-skeletons ''quasiquote
- (expand-quasiquote (cdr exp) (+ nesting 1))
- exp))
+ ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
+ (combine-skeletons ''quasiquote
+ (expand-quasiquote (cdr exp) (+ nesting 1))
+ exp))
; check for an
; unquote-splicing member,
; value and append the rest of
; the quasiquote result to it
- ((and (pair? (car exp))
- (eq? (car (car exp)) 'unquote-splicing)
- (= (length (car exp)) 2))
- (cond ((= nesting 0)
- (list 'append (car (cdr (car exp)))
- (expand-quasiquote (cdr exp) nesting))
- )
- (else
- (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
- (expand-quasiquote (cdr exp) nesting)
- exp))
- )
- )
+ ((and (pair? (car exp))
+ (eq? (car (car exp)) 'unquote-splicing)
+ (= (length (car exp)) 2))
+ (cond ((= nesting 0)
+ (list 'append (car (cdr (car exp)))
+ (expand-quasiquote (cdr exp) nesting))
+ )
+ (else
+ (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
+ (expand-quasiquote (cdr exp) nesting)
+ exp))
+ )
+ )
; for other lists, just glue
; the expansion of the first
; element to the expansion of
; the rest of the list
- (else (combine-skeletons (expand-quasiquote (car exp) nesting)
- (expand-quasiquote (cdr exp) nesting)
- exp)
- )
- )
- )
- )
- (expand-quasiquote x 0)
- ) () () ())
- )
- )
+ (else (combine-skeletons (expand-quasiquote (car exp) nesting)
+ (expand-quasiquote (cdr exp) nesting)
+ exp)
+ )
+ )
+ )
+ )
+ (expand-quasiquote x 0)
+ )
+ )
+ 'quasiquote)
;
; Define a variable without returning the value
; Useful when defining functions to avoid
; (define (name x y z) sexprs ...)
;
-(set! define
+(def! define
(macro (first rest)
-
; check for alternate lambda definition form
(cond ((list? first)
)
)
`(begin
- (set! ,first ,rest)
+ (def (quote ,first) ,rest)
(quote ,first))
)
)
; basic list accessors
-
(define (caar l) (car (car l)))
(define (cadr l) (car (cdr l)))
;
; (let ((x 1) (y)) (set! y (+ x 1)) y)
-(define let (macro (vars exprs)
- ((lambda (make-names make-vals)
-
- ;
- ; make the list of names in the let
- ;
-
- (set! make-names (lambda (vars)
- (cond ((not (null? vars))
- (cons (car (car vars))
- (make-names (cdr vars))))
- (else ())
- )
- )
- )
+(define let
+ (macro (vars exprs)
+ (define (make-names vars)
+ (cond ((not (null? vars))
+ (cons (car (car vars))
+ (make-names (cdr vars))))
+ (else ())
+ )
+ )
; the parameters to the lambda is a list
; of nils of the right length
- (set! make-vals (lambda (vars)
- (cond ((not (null? vars))
- (cons (cond ((null? (cdr (car vars))) ())
- (else
- (car (cdr (car vars))))
- )
- (make-vals (cdr vars))))
- (else ())
- )
- )
- )
+ (define (make-vals vars)
+ (cond ((not (null? vars))
+ (cons (cond ((null? (cdr (car vars))) ())
+ (else
+ (car (cdr (car vars))))
+ )
+ (make-vals (cdr vars))))
+ (else ())
+ )
+ )
; prepend the set operations
; to the expressions
; build the lambda.
- `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
- )
- ()
- ()
- )
- )
+ `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
+ )
)
;
; (let* ((x 1) (y)) (set! y (+ x 1)) y)
-(define let* (macro (vars exprs)
- ((lambda (make-names make-exprs make-nils)
+(define let*
+ (macro (vars exprs)
;
; make the list of names in the let
;
- (set! make-names (lambda (vars)
- (cond ((not (null? vars))
- (cons (car (car vars))
- (make-names (cdr vars))))
- (else ())
- )
- )
- )
+ (define (make-names vars)
+ (cond ((not (null? vars))
+ (cons (car (car vars))
+ (make-names (cdr vars))))
+ (else ())
+ )
+ )
; the set of expressions is
; the list of set expressions
; pre-pended to the
; expressions to evaluate
- (set! make-exprs (lambda (vars exprs)
- (cond ((not (null? vars))
- (cons
- (list set
- (list quote
- (car (car vars))
- )
- (cond ((null? (cdr (car vars))) ())
- (else (cadr (car vars))))
- )
- (make-exprs (cdr vars) exprs)
- )
- )
- (else exprs)
- )
- )
+ (define (make-exprs vars exprs)
+ (cond ((null? vars) exprs)
+ (else
+ (cons
+ (list set
+ (list quote
+ (car (car vars))
+ )
+ (cond ((null? (cdr (car vars))) ())
+ (else (cadr (car vars))))
)
+ (make-exprs (cdr vars) exprs)
+ )
+ )
+ )
+ )
; the parameters to the lambda is a list
; of nils of the right length
- (set! make-nils (lambda (vars)
- (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
- (else ())
- )
- )
- )
- ; prepend the set operations
- ; to the expressions
-
- (set! exprs (make-exprs vars exprs))
-
+ (define (make-nils vars)
+ (cond ((null? vars) ())
+ (else (cons () (make-nils (cdr vars))))
+ )
+ )
; build the lambda.
- `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars))
- )
- ()
- ()
- ()
- )
- )
+ `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
+ )
)
-(let* ((x 1)) x)
+(let* ((x 1) (y x)) (+ x y))
(define when (macro (test l) `(cond (,test ,@l))))
(define (list-tail x k)
(if (zero? k)
x
- (list-tail (cdr x) (- k 1)))))
+ (list-tail (cdr x) (- k 1))))
(list-tail '(1 2 3) 2)
(display "apply\n")
(apply cons '(a b))
-(define map (lexpr (proc lists)
- (let* ((args (lambda (lists)
- (if (null? lists) ()
- (cons (caar lists) (args (cdr lists))))))
- (next (lambda (lists)
- (if (null? lists) ()
- (cons (cdr (car lists)) (next (cdr lists))))))
- (domap (lambda (lists)
- (if (null? (car lists)) ()
- (cons (apply proc (args lists)) (domap (next lists)))
- )))
- )
- (domap lists))))
+(define map
+ (lexpr (proc lists)
+ (define (args lists)
+ (cond ((null? lists) ())
+ (else
+ (cons (caar lists) (args (cdr lists)))
+ )
+ )
+ )
+ (define (next lists)
+ (cond ((null? lists) ())
+ (else
+ (cons (cdr (car lists)) (next (cdr lists)))
+ )
+ )
+ )
+ (define (domap lists)
+ (cond ((null? (car lists)) ())
+ (else
+ (cons (apply proc (args lists)) (domap (next lists)))
+ )
+ )
+ )
+ (domap lists)
+ )
+ )
(map cadr '((a b) (d e) (g h)))
{
ao_lisp_v = _v;
+ ao_lisp_frame_init();
+
if (!ao_lisp_stack_push())
return AO_LISP_NIL;
struct ao_lisp_val *v = &vals->vals[f];
ao_lisp_poly_mark(v->val, 0);
- MDBG_MOVE("frame mark atom %s %d val %d at %d\n",
+ MDBG_MOVE("frame mark atom %s %d val %d at %d ",
ao_lisp_poly_atom(v->atom)->name,
MDBG_OFFSET(ao_lisp_ref(v->atom)),
MDBG_OFFSET(ao_lisp_ref(v->val)), f);
+ MDBG_DO(ao_lisp_poly_write(v->val));
+ MDBG_DO(printf("\n"));
}
}
return NULL;
vals->type = AO_LISP_FRAME_VALS;
vals->size = num;
+ memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val));
return vals;
}
vals = ao_lisp_frame_vals_new(num);
frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0));
frame->vals = ao_lisp_frame_vals_poly(vals);
+ frame->num = num;
}
- frame->num = num;
frame->prev = AO_LISP_NIL;
- memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val));
return frame;
}
void
ao_lisp_frame_free(struct ao_lisp_frame *frame)
{
- if (!ao_lisp_frame_marked(frame)) {
+ if (frame && !ao_lisp_frame_marked(frame)) {
int num = frame->num;
if (num < AO_LISP_FRAME_FREE) {
+ struct ao_lisp_frame_vals *vals;
+
+ vals = ao_lisp_poly_frame_vals(frame->vals);
+ memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val));
frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]);
ao_lisp_frame_free_list[num] = frame;
}
vals->vals[l].val = val;
}
-int
-ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val)
+ao_poly
+ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val)
{
- struct ao_lisp_frame *frame = *frame_ref;
ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL;
if (!ref) {
int f;
ao_lisp_poly_stash(0, atom);
ao_lisp_poly_stash(1, val);
- if (frame) {
- f = frame->num;
- frame = ao_lisp_frame_realloc(frame, f + 1);
- } else {
- f = 0;
- frame = ao_lisp_frame_new(1);
- *frame_ref = frame;
- }
+ f = frame->num;
+ frame = ao_lisp_frame_realloc(frame, f + 1);
if (!frame)
- return 0;
+ return AO_LISP_NIL;
atom = ao_lisp_poly_fetch(0);
val = ao_lisp_poly_fetch(1);
ao_lisp_frame_bind(frame, frame->num - 1, atom, val);
} else
*ref = val;
- return 1;
+ return val;
+}
+
+struct ao_lisp_frame *ao_lisp_frame_global;
+struct ao_lisp_frame *ao_lisp_frame_current;
+
+void
+ao_lisp_frame_init(void)
+{
+ if (!ao_lisp_frame_global)
+ ao_lisp_frame_global = ao_lisp_frame_new(0);
}
ao_poly
ao_macro_test_get(ao_poly atom)
{
- ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_global, atom);
+ ao_poly *ref = ao_lisp_atom_ref(atom);
if (ref)
return *ref;
return AO_LISP_NIL;
}
}
+ ao_lisp_frame_init();
+
/* Boolean values #f and #t */
ao_lisp_bool_get(0);
ao_lisp_bool_get(1);
if (funcs[f].func != prev_func)
b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args);
a = ao_lisp_atom_intern(funcs[f].name);
- ao_lisp_atom_set(ao_lisp_atom_poly(a),
+ ao_lisp_atom_def(ao_lisp_atom_poly(a),
ao_lisp_builtin_poly(b));
}
/* end of file value */
a = ao_lisp_atom_intern("eof");
- ao_lisp_atom_set(ao_lisp_atom_poly(a),
+ ao_lisp_atom_def(ao_lisp_atom_poly(a),
ao_lisp_atom_poly(a));
/* 'else' */
MDBG_MOVE("collect %d\n", ao_lisp_collects[style]);
#endif
+ MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global)));
/* The first time through, we're doing a full collect */
if (ao_lisp_last_top == 0)
}
addr = ao_lisp_pool + ao_lisp_top;
ao_lisp_top += size;
+ MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size);
return addr;
}
int
ao_lisp_stack_push(void)
{
- struct ao_lisp_stack *stack = ao_lisp_stack_new();
+ struct ao_lisp_stack *stack;
+
+ stack = ao_lisp_stack_new();
if (!stack)
return 0;
#include <stdlib.h>
#include <time.h>
-#define AO_LISP_POOL_TOTAL 3072
+#define AO_LISP_POOL_TOTAL 16384
#define AO_LISP_SAVE 1
#define DBG_MEM_STATS 1
; ANSI control sequences
-(define move-to (lambda (col row)
- (for-each display (list "\033[" row ";" col "H"))
- )
+(define (move-to col row)
+ (for-each display (list "\033[" row ";" col "H"))
)
-(define clear (lambda ()
- (display "\033[2J")
- )
+(define (clear)
+ (display "\033[2J")
)
-(define display-string (lambda (x y str)
- (move-to x y)
- (display str)
- )
+(define (display-string x y str)
+ (move-to x y)
+ (display str)
)
; Here's the pieces to display
(define towers ())
-(define one- (lambda (x) (- x 1)))
-(define one+ (lambda (x) (+ x 1)))
+(define (one- x) (- x 1))
+(define (one+ x) (+ x 1))
; Display one tower, clearing any
; space above it
-(define display-tower (lambda (x y clear tower)
- (cond ((= 0 clear)
- (cond ((not (null? tower))
- (display-string x y (car tower))
- (display-tower x (one+ y) 0 (cdr tower))
- )
- )
- )
- (else
- (display-string x y " ")
- (display-tower x (one+ y) (one- clear) tower)
- )
- )
- )
+(define (display-tower x y clear tower)
+ (cond ((= 0 clear)
+ (cond ((not (null? tower))
+ (display-string x y (car tower))
+ (display-tower x (one+ y) 0 (cdr tower))
+ )
+ )
+ )
+ (else
+ (display-string x y " ")
+ (display-tower x (one+ y) (one- clear) tower)
+ )
+ )
)
; Position of the top of the tower on the screen
; Shorter towers start further down the screen
-(define tower-pos (lambda (y tower)
- (- y (length tower))
- )
+(define (tower-pos y tower)
+ (- y (length tower))
)
; Display all of the towers, spaced 20 columns apart
-(define display-towers (lambda (x y towers)
- (cond ((not (null? towers))
- (display-tower x 0 (tower-pos y (car towers)) (car towers))
- (display-towers (+ x 20) y (cdr towers)))
- )
- )
+(define (display-towers x y towers)
+ (cond ((not (null? towers))
+ (display-tower x 0 (tower-pos y (car towers)) (car towers))
+ (display-towers (+ x 20) y (cdr towers)))
+ )
)
(define top 0)
; Display all of the towers, then move the cursor
; out of the way and flush the output
-(define display-hanoi (lambda ()
- (display-towers 0 top towers)
- (move-to 1 21)
- (flush-output)
- )
+(define (display-hanoi)
+ (display-towers 0 top towers)
+ (move-to 1 21)
+ (flush-output)
)
; Reset towers to the starting state, with
; all of the pieces in the first tower and the
; other two empty
-(define reset-towers (lambda ()
- (set! towers (list tower () ()))
- (set! top (+ (length tower) 3))
- (length tower)
- )
+(define (reset-towers)
+ (set! towers (list tower () ()))
+ (set! top (+ (length tower) 3))
+ (length tower)
)
; Replace a tower in the list of towers
; with a new value
-(define replace (lambda (list pos member)
- (cond ((= pos 0) (cons member (cdr list)))
- ((cons (car list) (replace (cdr list) (one- pos) member)))
- )
- )
+(define (replace list pos member)
+ (cond ((= pos 0) (cons member (cdr list)))
+ (else (cons (car list) (replace (cdr list) (one- pos) member)))
+ )
)
; Move a piece from the top of one tower
(define move-delay 10)
-(define move-piece (lambda (from to)
- (let* ((from-tower (list-ref towers from))
- (to-tower (list-ref towers to))
- (piece (car from-tower)))
- (set! from-tower (cdr from-tower))
- (set! to-tower (cons piece to-tower))
- (set! towers (replace towers from from-tower))
- (set! towers (replace towers to to-tower))
- (display-hanoi)
- (delay move-delay)
- )
- )
+(define (move-piece from to)
+ (let* ((from-tower (list-ref towers from))
+ (to-tower (list-ref towers to))
+ (piece (car from-tower)))
+ (set! from-tower (cdr from-tower))
+ (set! to-tower (cons piece to-tower))
+ (set! towers (replace towers from from-tower))
+ (set! towers (replace towers to to-tower))
+ (display-hanoi)
+ (delay move-delay)
+ )
)
; The implementation of the game
-(define _hanoi (lambda (n from to use)
- (cond ((= 1 n)
- (move-piece from to)
- )
- (else
- (_hanoi (one- n) from use to)
- (_hanoi 1 from to use)
- (_hanoi (one- n) use to from)
- )
- )
- )
+(define (_hanoi n from to use)
+ (cond ((= 1 n)
+ (move-piece from to)
+ )
+ (else
+ (_hanoi (one- n) from use to)
+ (_hanoi 1 from to use)
+ (_hanoi (one- n) use to from)
+ )
+ )
)
; A pretty interface which
; clears the screen and runs
; the program
-(define hanoi (lambda ()
- (let ((len))
- (set! len (reset-towers))
- (clear)
- (_hanoi len 0 1 2)
- (move-to 0 23)
- #t
- )
- )
+(define (hanoi)
+ (let ((len (reset-towers)))
+ (clear)
+ (_hanoi len 0 1 2)
+ (move-to 0 23)
+ #t
+ )
+ )
)
projects / fw / altos / commitdiff