diff options
Diffstat (limited to 'src/lisp')
| -rw-r--r-- | src/lisp/ao_lisp.h | 19 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_atom.c | 54 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_builtin.c | 13 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_builtin.txt | 1 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_const.lisp | 487 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_eval.c | 2 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_frame.c | 43 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_make_const.c | 8 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_mem.c | 2 | ||||
| -rw-r--r-- | src/lisp/ao_lisp_stack.c | 4 |
10 files changed, 324 insertions, 309 deletions
diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 96a7a05f..1f3fb2b4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -111,8 +111,9 @@ extern uint16_t ao_lisp_top; #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; @@ -627,7 +628,7 @@ struct ao_lisp_atom * 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); @@ -635,6 +636,9 @@ 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); @@ -757,12 +761,15 @@ ao_lisp_frame_free(struct ao_lisp_frame *frame); 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; @@ -864,7 +871,7 @@ ao_lisp_frames_dump(void) #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; diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index ede13567..a633c223 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -98,42 +98,25 @@ ao_lisp_atom_intern(char *name) 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); @@ -146,17 +129,28 @@ ao_lisp_atom_get(ao_poly 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) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index f13f2180..d4751ac2 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -208,6 +208,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) } 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) { ao_poly name; @@ -216,7 +227,7 @@ 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, diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6925ac17..abed7afe 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,6 +15,7 @@ atom unquote atom unquote_splicing unquote-splicing f_lambda set macro setq set! +f_lambda def nlambda cond nlambda begin nlambda while diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5c1aa75b..436da3dc 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,187 +14,185 @@ ; 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, @@ -202,36 +200,36 @@ ; 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 @@ -242,9 +240,8 @@ ; (define (name x y z) sexprs ...) ; -(set! define +(def! define (macro (first rest) - ; check for alternate lambda definition form (cond ((list? first) @@ -261,14 +258,13 @@ ) ) `(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))) @@ -392,47 +388,36 @@ ; ; (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)) + ) ) @@ -457,71 +442,58 @@ ; ; (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)))) @@ -545,7 +517,7 @@ (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) @@ -682,19 +654,32 @@ (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))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index fa25edf0..02329ee6 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -559,6 +559,8 @@ ao_lisp_eval(ao_poly _v) { ao_lisp_v = _v; + ao_lisp_frame_init(); + if (!ao_lisp_stack_push()) return AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index dd29e079..13a68b38 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -37,10 +37,12 @@ frame_vals_mark(void *addr) 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")); } } @@ -202,6 +204,7 @@ ao_lisp_frame_vals_new(int num) return NULL; vals->type = AO_LISP_FRAME_VALS; vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); return vals; } @@ -226,10 +229,9 @@ ao_lisp_frame_new(int num) 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; } @@ -245,9 +247,13 @@ ao_lisp_frame_mark(struct ao_lisp_frame *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; } @@ -291,30 +297,33 @@ ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly v 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); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f9bb5452..f3ea6be0 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -133,7 +133,7 @@ ao_has_macro(ao_poly p); 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; @@ -289,6 +289,8 @@ main(int argc, char **argv) } } + ao_lisp_frame_init(); + /* Boolean values #f and #t */ ao_lisp_bool_get(0); ao_lisp_bool_get(1); @@ -298,13 +300,13 @@ main(int argc, char **argv) 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' */ diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 890eba1b..3a704380 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -501,6 +501,7 @@ ao_lisp_collect(uint8_t style) 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) @@ -875,6 +876,7 @@ ao_lisp_alloc(int size) } addr = ao_lisp_pool + ao_lisp_top; ao_lisp_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); return addr; } diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 9d6cccc4..e7c89801 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -103,7 +103,9 @@ ao_lisp_stack_new(void) 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; |