And all of the library routines that use it, map, string-map and friends.
Signed-off-by: Keith Packard <keithp@keithp.com>
#define ao_lisp_pool ao_lisp_const
#define AO_LISP_POOL AO_LISP_POOL_CONST
-#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(#n))
+#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n))
#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v))
#define _ao_lisp_bool_true _bool(1)
#define _ao_lisp_bool_false _bool(0)
-#define _ao_lisp_atom_eof _atom(eof)
-#define _ao_lisp_atom_else _atom(else)
+#define _ao_lisp_atom_eof _atom("eof")
+#define _ao_lisp_atom_else _atom("else")
#define AO_LISP_BUILTIN_ATOMS
#include "ao_lisp_builtin.h"
eval_val, /* Value computed */
eval_formal, /* Formal computed */
eval_exec, /* Start a lambda evaluation */
+ eval_apply, /* Execute apply */
eval_cond, /* Start next cond clause */
eval_cond_test, /* Check cond condition */
eval_progn, /* Start next progn entry */
*/
#include "ao_lisp.h"
+#include <limits.h>
static int
builtin_size(void *addr)
#define AO_LISP_BUILTIN_CASENAME
#include "ao_lisp_builtin.h"
-#define _atomn(n) ao_lisp_poly_atom(_atom(n))
-
char *ao_lisp_args_name(uint8_t args) {
args &= AO_LISP_FUNC_MASK;
switch (args) {
- case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name;
- case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name;
- case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name;
- case AO_LISP_FUNC_MACRO: return _atomn(macro)->name;
+ 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 "???";
}
}
while (cons) {
ao_poly car = cons->car;
+ ao_poly cdr;
uint8_t rt = ao_lisp_poly_type(ret);
uint8_t ct = ao_lisp_poly_type(car);
else
return ao_lisp_error(AO_LISP_INVALID, "invalid args");
- cons = ao_lisp_poly_cons(cons->cdr);
+ cdr = cons->cdr;
+ if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS)
+ return ao_lisp_error(AO_LISP_INVALID, "improper list");
+ cons = ao_lisp_poly_cons(cdr);
}
return ret;
}
return cons->car;
}
+ao_poly
+ao_lisp_do_apply(struct ao_lisp_cons *cons)
+{
+ if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX))
+ return AO_LISP_NIL;
+ ao_lisp_stack->state = eval_apply;
+ return ao_lisp_cons_poly(cons);
+}
+
ao_poly
ao_lisp_do_read(struct ao_lisp_cons *cons)
{
return ao_lisp_do_typep(AO_LISP_BOOL, cons);
}
+ao_poly
+ao_lisp_do_procedurep(struct ao_lisp_cons *cons)
+{
+ if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
+ return AO_LISP_NIL;
+ switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) {
+ case AO_LISP_BUILTIN:
+ case AO_LISP_LAMBDA:
+ return _ao_lisp_bool_true;
+ default:
+ return _ao_lisp_bool_false;
+ }
+}
+
/* This one is special -- a list is either nil or
* a 'proper' list with only cons cells
*/
-lambda eval
-lambda read
-nlambda lambda
-nlambda lexpr
-nlambda nlambda
-nlambda macro
-lambda car
-lambda cdr
-lambda cons
-lambda last
-lambda length
-nlambda quote
-lambda set
-macro setq set!
-nlambda cond
-nlambda progn
-nlambda while
-lexpr print
-lexpr patom
-lexpr plus +
-lexpr minus -
-lexpr times *
-lexpr divide /
-lexpr modulo modulo %
-lexpr remainder
-lexpr quotient
-lexpr equal = eq? eqv?
-lexpr less <
-lexpr greater >
-lexpr less_equal <=
-lexpr greater_equal >=
-lambda list_to_string list->string
-lambda string_to_list string->list
-lambda flush
-lambda delay
-lexpr led
-lambda save
-lambda restore
-lambda call_cc call/cc
-lambda collect
-lambda nullp null?
-lambda not
-lambda listp list?
-lambda pairp pair?
-lambda numberp number? integer?
-lambda booleanp boolean?
-lambda set_car set-car!
-lambda set_cdr set-cdr!
-lambda symbolp symbol?
-lambda symbol_to_string symbol->string
-lambda string_to_symbol string->symbol
-lambda stringp string?
+f_lambda eval
+f_lambda read
+nlambda lambda
+nlambda lexpr
+nlambda nlambda
+nlambda macro
+f_lambda car
+f_lambda cdr
+f_lambda cons
+f_lambda last
+f_lambda length
+nlambda quote
+f_lambda set
+macro setq set!
+nlambda cond
+nlambda progn
+nlambda while
+f_lexpr print
+f_lexpr patom
+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 list_to_string list->string
+f_lambda string_to_list string->list
+f_lambda flush
+f_lambda delay
+f_lexpr led
+f_lambda save
+f_lambda restore
+f_lambda call_cc call-with-current-continuation call/cc
+f_lambda collect
+f_lambda nullp null?
+f_lambda not
+f_lambda listp list?
+f_lambda pairp pair?
+f_lambda numberp number? integer?
+f_lambda booleanp boolean?
+f_lambda set_car set-car!
+f_lambda set_cdr set-cdr!
+f_lambda symbolp symbol?
+f_lambda symbol_to_string symbol->string
+f_lambda string_to_symbol string->symbol
+f_lambda stringp string?
+f_lambda procedurep procedure?
+lexpr apply
struct ao_lisp_cons *cons = addr;
for (;;) {
+ ao_poly cdr = cons->cdr;
+
ao_lisp_poly_mark(cons->car, 1);
- cons = ao_lisp_poly_cons(cons->cdr);
- if (!cons)
+ if (!cdr)
break;
+ if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) {
+ ao_lisp_poly_mark(cdr, 1);
+ break;
+ }
+ cons = ao_lisp_poly_cons(cdr);
if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons))
break;
}
return;
for (;;) {
- struct ao_lisp_cons *cdr;
- int ret;
+ ao_poly cdr;
+ struct ao_lisp_cons *c;
+ int ret;
MDBG_MOVE("cons_move start %d (%d, %d)\n",
MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr)));
(void) ao_lisp_poly_move(&cons->car, 1);
- cdr = ao_lisp_poly_cons(cons->cdr);
+ cdr = cons->cdr;
if (!cdr)
break;
- ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr);
- if (cdr != ao_lisp_poly_cons(cons->cdr))
- cons->cdr = ao_lisp_cons_poly(cdr);
+ if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) {
+ (void) ao_lisp_poly_move(&cons->cdr, 1);
+ break;
+ }
+ c = ao_lisp_poly_cons(cdr);
+ ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c);
+ if (c != ao_lisp_poly_cons(cons->cdr))
+ cons->cdr = ao_lisp_cons_poly(c);
MDBG_MOVE("cons_move end %d (%d, %d)\n",
MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr)));
if (ret)
break;
- cons = cdr;
+ cons = c;
}
}
; expressions to evaluate
(set! make-exprs (lambda (vars exprs)
- (cond ((not (null? vars)) (cons
- (list set
- (list quote
- (car (car vars))
- )
- (cadr (car vars))
- )
- (make-exprs (cdr 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)
+ )
+ )
(exprs)
)
)
(define string (lexpr (chars) (list->string chars)))
+(patom "apply\n")
+(apply cons '(a b))
+
+(define save ())
+
+(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))))
+
+(map cadr '((a b) (d e) (g h)))
+
+(define for-each (lexpr (proc lists)
+ (apply map proc lists)
+ #t))
+
+(for-each patom '("hello" " " "world" "\n"))
+
+(define string-map (lexpr (proc strings)
+ (let ((make-lists (lambda (strings)
+ (if (null? strings) ()
+ (cons (string->list (car strings)) (make-lists (cdr strings))))))
+ )
+ (list->string (apply map proc (make-lists strings))))))
+
+(string-map 1+ "HAL")
+
+(define string-for-each (lexpr (proc strings)
+ (apply string-map proc strings)
+ #t))
+
+(string-for-each patom "IBM")
+
+
+(call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (print "test" x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+
;(define number->string (lexpr (arg opt)
; (let ((base (if (null? opt) 10 (car opt)))
;
struct ao_lisp_stack *ao_lisp_stack;
ao_poly ao_lisp_v;
+uint8_t ao_lisp_skip_cons_free;
ao_poly
ao_lisp_set_cond(struct ao_lisp_cons *c)
DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n");
});
builtin = ao_lisp_poly_builtin(ao_lisp_v);
- if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack))
+ if (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));
ao_lisp_v = v;
DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
break;
}
+ ao_lisp_skip_cons_free = 0;
+ return 1;
+}
+
+/*
+ * Finish setting up the apply evaluation
+ *
+ * The value is the list to execute
+ */
+static int
+ao_lisp_eval_apply(void)
+{
+ struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v);
+ struct ao_lisp_cons *cdr, *prev;
+
+ /* Glue the arguments into the right shape. That's all but the last
+ * concatenated onto the last
+ */
+ cdr = cons;
+ for (;;) {
+ prev = cdr;
+ cdr = ao_lisp_poly_cons(prev->cdr);
+ if (cdr->cdr == AO_LISP_NIL)
+ break;
+ }
+ DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n");
+ prev->cdr = cdr->car;
+ ao_lisp_stack->values = ao_lisp_v;
+ ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car;
+ DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n");
+ ao_lisp_stack->state = eval_exec;
+ ao_lisp_skip_cons_free = 1;
return 1;
}
[eval_val] = ao_lisp_eval_val,
[eval_formal] = ao_lisp_eval_formal,
[eval_exec] = ao_lisp_eval_exec,
+ [eval_apply] = ao_lisp_eval_apply,
[eval_cond] = ao_lisp_eval_cond,
[eval_cond_test] = ao_lisp_eval_cond_test,
[eval_progn] = ao_lisp_eval_progn,
};
const char *ao_lisp_state_names[] = {
- "sexpr",
- "val",
- "formal",
- "exec",
- "cond",
- "cond_test",
- "progn",
- "while",
- "while_test",
- "macro",
+ [eval_sexpr] = "sexpr",
+ [eval_val] = "val",
+ [eval_formal] = "formal",
+ [eval_exec] = "exec",
+ [eval_apply] = "apply",
+ [eval_cond] = "cond",
+ [eval_cond_test] = "cond_test",
+ [eval_progn] = "progn",
+ [eval_while] = "while",
+ [eval_while_test] = "while_test",
+ [eval_macro] = "macro",
};
/*
} builtin_t;
string[string] type_map = {
- "lambda" => "F_LAMBDA",
+ "lambda" => "LAMBDA",
"nlambda" => "NLAMBDA",
- "lexpr" => "F_LEXPR",
+ "lexpr" => "LEXPR",
"macro" => "MACRO",
+ "f_lambda" => "F_LAMBDA",
+ "f_lexpr" => "F_LEXPR",
};
string[*]
printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n");
printf("\tswitch(b) {\n");
for (int i = 0; i < dim(builtins); i++)
- printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n",
- builtins[i].c_name, builtins[i].c_name);
+ printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n",
+ builtins[i].c_name, builtins[i].lisp_names[0]);
printf("\tdefault: return \"???\";\n");
printf("\t}\n");
printf("}\n");
for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
printf("#define _ao_lisp_atom_");
cify_lisp(builtins[i].lisp_names[j]);
- printf(" _atom(");
- cify_lisp(builtins[i].lisp_names[j]);
- printf(")\n");
+ printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]);
}
}
printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n");
if (!push_read_stack(cons, read_state))
return AO_LISP_NIL;
cons++;
- read_state |= READ_IN_QUOTE;
+ read_state = READ_IN_QUOTE;
v = _ao_lisp_atom_quote;
break;
case CLOSE:
projects / fw / altos / commitdiff