#define AO_LISP_FUNC_LAMBDA 0
#define AO_LISP_FUNC_NLAMBDA 1
#define AO_LISP_FUNC_MACRO 2
-#define AO_LISP_FUNC_LEXPR 3
#define AO_LISP_FUNC_FREE_ARGS 0x80
#define AO_LISP_FUNC_MASK 0x7f
#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA)
#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA)
#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO)
-#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR)
struct ao_lisp_builtin {
uint8_t type;
args &= AO_LISP_FUNC_MASK;
switch (args) {
case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name;
- case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name;
case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name;
case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name;
default: return "???";
static const ao_poly ao_lisp_args_atoms[] = {
[AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda,
- [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr,
[AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda,
[AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro,
};
f_lambda eval
f_lambda read
nlambda lambda
-nlambda lexpr
nlambda nlambda
nlambda macro
f_lambda car
nlambda cond
nlambda begin
nlambda while
-f_lexpr write
-f_lexpr display
-f_lexpr plus +
-f_lexpr minus -
-f_lexpr times *
-f_lexpr divide /
-f_lexpr modulo modulo %
-f_lexpr remainder
-f_lexpr quotient
-f_lexpr equal = eq? eqv?
-f_lexpr less <
-f_lexpr greater >
-f_lexpr less_equal <=
-f_lexpr greater_equal >=
+f_lambda write
+f_lambda display
+f_lambda plus +
+f_lambda minus -
+f_lambda times *
+f_lambda divide /
+f_lambda modulo modulo %
+f_lambda remainder
+f_lambda quotient
+f_lambda equal = eq? eqv?
+f_lambda less <
+f_lambda greater >
+f_lambda less_equal <=
+f_lambda greater_equal >=
f_lambda list_to_string list->string
f_lambda string_to_list string->list
f_lambda flush_output flush-output
f_lambda delay
-f_lexpr led
+f_lambda led
f_lambda save
f_lambda restore
f_lambda call_cc call-with-current-continuation call/cc
f_lambda string_to_symbol string->symbol
f_lambda stringp string?
f_lambda procedurep procedure?
-lexpr apply
+lambda apply
f_lambda read_char read-char
f_lambda write_char write-char
f_lambda exit
; Lisp code placed in ROM
; return a list containing all of the arguments
-(def (quote list) (lexpr (l) l))
+(def (quote list) (lambda l l))
(def (quote def!)
- (macro (name value rest)
+ (macro (name value)
(list
def
(list quote name)
(begin
(def! append
- (lexpr (args)
+ (lambda args
(def! append-list
(lambda (a b)
(cond ((null? a) b)
(begin
(def! or
- (macro (l)
+ (macro l
(def! _or
(lambda (l)
(cond ((null? l) #f)
(begin
(def! and
- (macro (l)
+ (macro l
(def! _and
(lambda (l)
(cond ((null? l) #t)
)
)
)
- (_and l)))
+ (_and l)
+ )
+ )
'and)
; execute to resolve macros
(begin
(def! quasiquote
- (macro (x rest)
+ (macro (x)
(def! constant?
; A constant value is either a pair starting with quote,
; or anything which is neither a pair nor a symbol
)
)
)
- (expand-quasiquote x 0)
+ (def! result (expand-quasiquote x 0))
+ result
)
)
'quasiquote)
+
;
; Define a variable without returning the value
; Useful when defining functions to avoid
(begin
(def! define
- (macro (first rest)
+ (macro (first . rest)
; check for alternate lambda definition form
(cond ((list? first)
(set! rest (car rest))
)
)
- `(begin
- (def (quote ,first) ,rest)
- (quote ,first))
+ (def! result `(,begin
+ (,def (,quote ,first) ,rest)
+ (,quote ,first))
+ )
+ result
)
)
'define
(define (caddr l) (car (cdr (cdr l))))
-(define (list-tail x k)
- (if (zero? k)
- x
- (list-tail (cdr x (- k 1)))
- )
- )
-
-(define (list-ref x k)
- (car (list-tail x k))
- )
-
; (if <condition> <if-true>)
; (if <condition> <if-true> <if-false)
(define if
- (macro (test args)
+ (macro (test . args)
(cond ((null? (cdr args))
`(cond (,test ,(car args)))
)
; simple math operators
-(define zero? (macro (value rest) `(eq? ,value 0)))
+(define zero? (macro (value) `(eq? ,value 0)))
(zero? 1)
(zero? 0)
(zero? "hello")
-(define positive? (macro (value rest) `(> ,value 0)))
+(define positive? (macro (value) `(> ,value 0)))
(positive? 12)
(positive? -12)
-(define negative? (macro (value rest) `(< ,value 0)))
+(define negative? (macro (value) `(< ,value 0)))
(negative? 12)
(negative? -12)
(abs 12)
(abs -12)
-(define max (lexpr (first rest)
+(define max (lambda (first . rest)
(while (not (null? rest))
(cond ((< first (car rest))
(set! first (car rest)))
(max 1 2 3)
(max 3 2 1)
-(define min (lexpr (first rest)
+(define min (lambda (first . rest)
(while (not (null? rest))
(cond ((> first (car rest))
(set! first (car rest)))
(odd? -1)
+(define (list-tail x k)
+ (if (zero? k)
+ x
+ (list-tail (cdr x (- k 1)))
+ )
+ )
+
+(define (list-ref x k)
+ (car (list-tail x k))
+ )
+
; define a set of local
; variables all at once and
; then evaluate a list of
; (let ((x 1) (y)) (set! y (+ x 1)) y)
(define let
- (macro (vars exprs)
+ (macro (vars . exprs)
(define (make-names vars)
(cond ((not (null? vars))
(cons (car (car vars))
; (let* ((x 1) (y)) (set! y (+ x 1)) y)
(define let*
- (macro (vars exprs)
+ (macro (vars . exprs)
;
; make the list of names in the let
(let* ((x 1) (y x)) (+ x y))
-(define when (macro (test l) `(cond (,test ,@l))))
+(define when (macro (test . l) `(cond (,test ,@l))))
(when #t (write 'when))
-(define unless (macro (test l) `(cond ((not ,test) ,@l))))
+(define unless (macro (test . l) `(cond ((not ,test) ,@l))))
(unless #f (write 'unless))
(equal? '(a b c) '(a b c))
(equal? '(a b c) '(a b b))
-(define member (lexpr (obj list test?)
+(define member (lambda (obj list . test?)
(cond ((null? list)
#f
)
(char-downcase #\0)
(char-downcase #\space)
-(define string (lexpr (chars) (list->string chars)))
+(define string (lambda chars (list->string chars)))
(display "apply\n")
(apply cons '(a b))
(define map
- (lexpr (proc lists)
+ (lambda (proc . lists)
(define (args lists)
(cond ((null? lists) ())
(else
(map cadr '((a b) (d e) (g h)))
-(define for-each (lexpr (proc lists)
+(define for-each (lambda (proc . lists)
(apply map proc lists)
#t))
)
)
-(define string-map (lexpr (proc strings)
+(define string-map (lambda (proc . strings)
(list->string (apply map proc (_string-ml strings))))))
(string-map (lambda (x) (+ 1 x)) "HAL")
-(define string-for-each (lexpr (proc strings)
+(define string-for-each (lambda (proc . strings)
(apply for-each proc (_string-ml strings))))
(string-for-each write-char "IBM\n")
(define repeat
- (macro (count rest)
+ (macro (count . rest)
(define counter '__count__)
(cond ((pair? count)
(set! counter (car count))
(repeat (x 3) (write 'goodbye x))
(define case
- (macro (test l)
+ (macro (test . l)
; construct the body of the
; case, dealing with the
; lambda version ( => lambda)
(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
-;(define number->string (lexpr (arg opt)
+;(define number->string (lambda (arg . opt)
; (let ((base (if (null? opt) 10 (car opt)))
;
;
* A formal has been computed.
*
* If this is the first formal, then check to see if we've got a
- * lamda/lexpr or macro/nlambda.
+ * lamda, macro or nlambda.
*
- * For lambda/lexpr, go compute another formal. This will terminate
+ * For lambda, go compute another formal. This will terminate
* when the sexpr state sees nil.
*
* For macro/nlambda, we're done, so move the sexprs into the values
if (!ao_lisp_stack->values) {
switch (func_type(ao_lisp_v)) {
case AO_LISP_FUNC_LAMBDA:
- case AO_LISP_FUNC_LEXPR:
- DBGI(".. lambda or lexpr\n");
+ DBGI(".. lambda\n");
break;
case AO_LISP_FUNC_MACRO:
/* Evaluate the result once more */
DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n");
});
builtin = ao_lisp_poly_builtin(ao_lisp_v);
- if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free)
- ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values));
+ if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) {
+ struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
+ ao_lisp_stack->values = AO_LISP_NIL;
+ ao_lisp_cons_free(cons);
+ }
ao_lisp_v = v;
ao_lisp_stack->values = AO_LISP_NIL;
ao_poly
ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args)
{
+ struct ao_lisp_lambda *lambda;
+ ao_poly formal;
+ struct ao_lisp_cons *cons;
+
+ formal = ao_lisp_arg(code, 0);
+ while (formal != AO_LISP_NIL) {
+ switch (ao_lisp_poly_type(formal)) {
+ case AO_LISP_CONS:
+ cons = ao_lisp_poly_cons(formal);
+ if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM)
+ return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car);
+ formal = cons->cdr;
+ break;
+ case AO_LISP_ATOM:
+ formal = AO_LISP_NIL;
+ break;
+ default:
+ return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal);
+ }
+ }
+
ao_lisp_cons_stash(0, code);
- struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda));
+ lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda));
code = ao_lisp_cons_fetch(0);
- struct ao_lisp_cons *arg;
- int f;
-
if (!lambda)
return AO_LISP_NIL;
- if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1))
- return AO_LISP_NIL;
- f = 0;
- arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
- while (arg) {
- if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM)
- return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f);
- arg = ao_lisp_poly_cons(arg->cdr);
- f++;
- }
-
lambda->type = AO_LISP_LAMBDA;
lambda->args = args;
lambda->code = ao_lisp_cons_poly(code);
return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA);
}
-ao_poly
-ao_lisp_do_lexpr(struct ao_lisp_cons *cons)
-{
- return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR);
-}
-
ao_poly
ao_lisp_do_nlambda(struct ao_lisp_cons *cons)
{
struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v);
struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code);
- struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
+ ao_poly formals;
struct ao_lisp_frame *next_frame;
int args_wanted;
+ ao_poly varargs = AO_LISP_NIL;
int args_provided;
int f;
struct ao_lisp_cons *vals;
DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n");
- args_wanted = ao_lisp_cons_length(args);
+ args_wanted = 0;
+ for (formals = ao_lisp_arg(code, 0);
+ ao_lisp_is_pair(formals);
+ formals = ao_lisp_poly_cons(formals)->cdr)
+ ++args_wanted;
+ if (formals != AO_LISP_NIL) {
+ if (ao_lisp_poly_type(formals) != AO_LISP_ATOM)
+ return ao_lisp_error(AO_LISP_INVALID, "bad lambda form");
+ varargs = formals;
+ }
/* Create a frame to hold the variables
*/
args_provided = ao_lisp_cons_length(cons) - 1;
- if (lambda->args == AO_LISP_FUNC_LAMBDA) {
+ if (varargs == AO_LISP_NIL) {
if (args_wanted != args_provided)
return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided);
} else {
- if (args_provided < args_wanted - 1)
+ if (args_provided < args_wanted)
return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided);
}
- next_frame = ao_lisp_frame_new(args_wanted);
+ ao_lisp_poly_stash(1, varargs);
+ next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL));
+ varargs = ao_lisp_poly_fetch(1);
+ if (!next_frame)
+ return AO_LISP_NIL;
/* Re-fetch all of the values in case something moved */
lambda = ao_lisp_poly_lambda(ao_lisp_v);
cons = ao_lisp_poly_cons(ao_lisp_stack->values);
code = ao_lisp_poly_cons(lambda->code);
- args = ao_lisp_poly_cons(ao_lisp_arg(code, 0));
+ formals = ao_lisp_arg(code, 0);
vals = ao_lisp_poly_cons(cons->cdr);
next_frame->prev = lambda->frame;
ao_lisp_frame_current = next_frame;
ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
- switch (lambda->args) {
- case AO_LISP_FUNC_LAMBDA:
- for (f = 0; f < args_wanted; f++) {
- DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
- ao_lisp_frame_bind(next_frame, f, args->car, vals->car);
- args = ao_lisp_poly_cons(args->cdr);
- vals = ao_lisp_poly_cons(vals->cdr);
- }
- if (!ao_lisp_stack_marked(ao_lisp_stack))
+ for (f = 0; f < args_wanted; f++) {
+ struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals);
+ DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
+ ao_lisp_frame_bind(next_frame, f, arg->car, vals->car);
+ formals = arg->cdr;
+ vals = ao_lisp_poly_cons(vals->cdr);
+ }
+ if (varargs) {
+ DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n");
+ /*
+ * Bind the rest of the arguments to the final parameter
+ */
+ ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_cons_poly(vals));
+ } else {
+ /*
+ * Mark the cons cells from the actuals as freed for immediate re-use, unless
+ * the actuals point into the source function (nlambdas and macros), or if the
+ * stack containing them was copied as a part of a continuation
+ */
+ if (lambda->args == AO_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) {
+ ao_lisp_stack->values = AO_LISP_NIL;
ao_lisp_cons_free(cons);
- cons = NULL;
- break;
- case AO_LISP_FUNC_LEXPR:
- case AO_LISP_FUNC_NLAMBDA:
- case AO_LISP_FUNC_MACRO:
- for (f = 0; f < args_wanted - 1; f++) {
- DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n");
- ao_lisp_frame_bind(next_frame, f, args->car, vals->car);
- args = ao_lisp_poly_cons(args->cdr);
- vals = ao_lisp_poly_cons(vals->cdr);
}
- DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n");
- ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals));
- break;
- default:
- break;
}
DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n");
DBG_STACK();
string[string] type_map = {
"lambda" => "LAMBDA",
"nlambda" => "NLAMBDA",
- "lexpr" => "LEXPR",
"macro" => "MACRO",
"f_lambda" => "F_LAMBDA",
- "f_lexpr" => "F_LEXPR",
"atom" => "atom",
};
struct ao_lisp_cons *cons;
struct ao_lisp_lambda *lambda;
ao_poly m;
+ ao_poly list;
if (p == AO_LISP_NIL)
return AO_LISP_NIL;
if ((p = ao_is_macro(cons->car)))
break;
- cons = ao_lisp_poly_cons(cons->cdr);
+ list = cons->cdr;
p = AO_LISP_NIL;
- while (cons) {
+ while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) {
+ cons = ao_lisp_poly_cons(list);
m = ao_has_macro(cons->car);
if (m) {
p = m;
break;
}
- cons = ao_lisp_poly_cons(cons->cdr);
+ list = cons->cdr;
}
break;
projects / fw / altos / commitdiff