mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 06:39:17 +02:00
fixing nested let-syntax hygiene, simplifying error handling
also providing better errors in some cases, and exiting with a non-zero status on script errors
This commit is contained in:
Alex Shinn
parent
01f21cc905
commit
0efd491c24
12 changed files with 763 additions and 119 deletions
3
Makefile
3
Makefile
|
|
@ -128,6 +128,9 @@ test-numbers: all
|
|||
test-match: all
|
||||
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/match-tests.scm
|
||||
|
||||
test-loop: all
|
||||
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/loop-tests.scm
|
||||
|
||||
test: all
|
||||
LD_LIBRARY_PATH=.:$(LD_LIBRARY_PATH) ./chibi-scheme$(EXE) tests/r5rs-tests.scm
|
||||
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@
|
|||
string-fill! vector? make-vector vector vector-length vector-ref
|
||||
vector-set! vector->list list->vector vector-fill! procedure? apply
|
||||
map for-each force call-with-current-continuation values
|
||||
call-with-values scheme-report-environment
|
||||
call-with-values interaction-environment scheme-report-environment
|
||||
null-environment call-with-input-file call-with-output-file
|
||||
input-port? output-port? current-input-port current-output-port
|
||||
with-input-from-file with-output-to-file open-input-file
|
||||
|
|
|
|||
112
eval.c
112
eval.c
|
|
@ -16,6 +16,7 @@ static int scheme_initialized_p = 0;
|
|||
#define sexp_disasm(...)
|
||||
#endif
|
||||
|
||||
static sexp analyze (sexp ctx, sexp x);
|
||||
static void generate (sexp ctx, sexp x);
|
||||
static sexp sexp_make_null_env (sexp ctx, sexp version);
|
||||
static sexp sexp_make_standard_env (sexp ctx, sexp version);
|
||||
|
|
@ -35,7 +36,7 @@ static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) {
|
|||
|
||||
/********************** environment utilities ***************************/
|
||||
|
||||
static sexp sexp_env_cell (sexp e, sexp key) {
|
||||
sexp sexp_env_cell (sexp e, sexp key) {
|
||||
sexp ls;
|
||||
|
||||
do {
|
||||
|
|
@ -87,7 +88,7 @@ void sexp_env_define (sexp ctx, sexp e, sexp key, sexp value) {
|
|||
}
|
||||
}
|
||||
|
||||
static sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
||||
sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
||||
sexp_gc_var2(e, tmp);
|
||||
sexp_gc_preserve2(ctx, e, tmp);
|
||||
e = sexp_alloc_type(ctx, env, SEXP_ENV);
|
||||
|
|
@ -101,22 +102,6 @@ static sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value) {
|
|||
return e;
|
||||
}
|
||||
|
||||
#if 0
|
||||
static sexp sexp_chain_env (sexp ctx, sexp env1, sexp env2) {
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
res = env2;
|
||||
if (env1 && sexp_envp(env1)) {
|
||||
res = sexp_alloc_type(ctx, env, SEXP_ENV);
|
||||
sexp_env_parent(res) = sexp_chain_env(ctx, sexp_env_parent(env1), env2);
|
||||
sexp_env_bindings(res) = sexp_env_bindings(env1);
|
||||
sexp_env_lambda(res) = sexp_env_lambda(env1);
|
||||
}
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) {
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
|
|
@ -387,7 +372,7 @@ static sexp analyze_app (sexp ctx, sexp x) {
|
|||
sexp_gc_preserve2(ctx, res, tmp);
|
||||
for (res=SEXP_NULL; sexp_pairp(x); x=sexp_cdr(x)) {
|
||||
sexp_push(ctx, res, SEXP_FALSE);
|
||||
tmp = sexp_analyze(ctx, sexp_car(x));
|
||||
tmp = analyze(ctx, sexp_car(x));
|
||||
if (sexp_exceptionp(tmp)) {
|
||||
res = tmp;
|
||||
break;
|
||||
|
|
@ -405,7 +390,7 @@ static sexp analyze_seq (sexp ctx, sexp ls) {
|
|||
if (sexp_nullp(ls))
|
||||
res = SEXP_VOID;
|
||||
else if (sexp_nullp(sexp_cdr(ls)))
|
||||
res = sexp_analyze(ctx, sexp_car(ls));
|
||||
res = analyze(ctx, sexp_car(ls));
|
||||
else {
|
||||
res = sexp_alloc_type(ctx, seq, SEXP_SEQ);
|
||||
tmp = analyze_app(ctx, ls);
|
||||
|
|
@ -425,7 +410,8 @@ static sexp analyze_var_ref (sexp ctx, sexp x) {
|
|||
cell = sexp_env_cell(env, x);
|
||||
if (! cell) {
|
||||
if (sexp_synclop(x)) {
|
||||
if (sexp_truep(sexp_memq(ctx, x, sexp_context_fv(ctx))))
|
||||
if (sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_context_fv(ctx)))
|
||||
&& sexp_not(sexp_memq(ctx, sexp_synclo_expr(x), sexp_synclo_free_vars(x))))
|
||||
env = sexp_synclo_env(x);
|
||||
x = sexp_synclo_expr(x);
|
||||
}
|
||||
|
|
@ -450,7 +436,7 @@ static sexp analyze_set (sexp ctx, sexp x) {
|
|||
ref = analyze_var_ref(ctx, sexp_cadr(x));
|
||||
if (sexp_lambdap(sexp_ref_loc(ref)))
|
||||
sexp_insert(ctx, sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
|
||||
value = sexp_analyze(ctx, sexp_caddr(x));
|
||||
value = analyze(ctx, sexp_caddr(x));
|
||||
if (sexp_exceptionp(ref))
|
||||
res = ref;
|
||||
else if (sexp_exceptionp(value))
|
||||
|
|
@ -494,7 +480,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) {
|
|||
value = analyze_lambda(ctx2, sexp_cons(ctx2, SEXP_VOID, tmp));
|
||||
} else {
|
||||
name = sexp_cadr(tmp);
|
||||
value = sexp_analyze(ctx2, sexp_caddr(tmp));
|
||||
value = analyze(ctx2, sexp_caddr(tmp));
|
||||
}
|
||||
if (sexp_exceptionp(value)) sexp_return(res, value);
|
||||
sexp_push(ctx2, defs,
|
||||
|
|
@ -521,10 +507,10 @@ static sexp analyze_if (sexp ctx, sexp x) {
|
|||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) {
|
||||
res = sexp_compile_error(ctx, "bad if syntax", x);
|
||||
} else {
|
||||
test = sexp_analyze(ctx, sexp_cadr(x));
|
||||
pass = sexp_analyze(ctx, sexp_caddr(x));
|
||||
test = analyze(ctx, sexp_cadr(x));
|
||||
pass = analyze(ctx, sexp_caddr(x));
|
||||
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_VOID;
|
||||
fail = sexp_analyze(ctx, fail_expr);
|
||||
fail = analyze(ctx, fail_expr);
|
||||
res = (sexp_exceptionp(test) ? test : sexp_exceptionp(pass) ? pass :
|
||||
sexp_exceptionp(fail) ? fail : sexp_make_cnd(ctx, test, pass, fail));
|
||||
}
|
||||
|
|
@ -558,7 +544,7 @@ static sexp analyze_define (sexp ctx, sexp x) {
|
|||
tmp = sexp_cons(ctx, SEXP_VOID, tmp);
|
||||
value = analyze_lambda(ctx, tmp);
|
||||
} else
|
||||
value = sexp_analyze(ctx, sexp_caddr(x));
|
||||
value = analyze(ctx, sexp_caddr(x));
|
||||
ref = analyze_var_ref(ctx, name);
|
||||
if (sexp_exceptionp(ref))
|
||||
res = ref;
|
||||
|
|
@ -643,7 +629,7 @@ static sexp analyze_letrec_syntax (sexp ctx, sexp x) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_analyze (sexp ctx, sexp object) {
|
||||
static sexp analyze (sexp ctx, sexp object) {
|
||||
sexp op;
|
||||
sexp_gc_var4(res, tmp, x, cell);
|
||||
sexp_gc_preserve4(ctx, res, tmp, x, cell);
|
||||
|
|
@ -674,7 +660,14 @@ sexp sexp_analyze (sexp ctx, sexp object) {
|
|||
case CORE_BEGIN:
|
||||
res = analyze_seq(ctx, sexp_cdr(x)); break;
|
||||
case CORE_QUOTE:
|
||||
res = sexp_make_lit(ctx, sexp_strip_synclos(ctx, sexp_cadr(x)));
|
||||
case CORE_SYNTAX_QUOTE:
|
||||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_nullp(sexp_cddr(x))))
|
||||
res = sexp_compile_error(ctx, "bad quote form", x);
|
||||
else
|
||||
res = sexp_make_lit(ctx,
|
||||
(sexp_core_code(op) == CORE_QUOTE) ?
|
||||
sexp_strip_synclos(ctx, sexp_cadr(x)) :
|
||||
sexp_cadr(x));
|
||||
break;
|
||||
case CORE_DEFINE_SYNTAX:
|
||||
res = analyze_define_syntax(ctx, x); break;
|
||||
|
|
@ -691,12 +684,9 @@ sexp sexp_analyze (sexp ctx, sexp object) {
|
|||
tmp = sexp_cons(ctx, x, tmp);
|
||||
x = sexp_make_child_context(ctx, sexp_context_lambda(ctx));
|
||||
x = sexp_apply(x, sexp_macro_proc(op), tmp);
|
||||
if (sexp_exceptionp(x) && sexp_not(sexp_exception_source(x)))
|
||||
sexp_exception_source(x) = sexp_pair_source(sexp_car(tmp));
|
||||
goto loop;
|
||||
/* XXXX need to handle free vars, simplify */
|
||||
/* tmp = sexp_make_child_context(ctx, sexp_context_lambda(ctx)); */
|
||||
/* sexp_context_env(tmp) */
|
||||
/* = sexp_chain_env(ctx, sexp_macro_env(op), sexp_context_env(tmp)); */
|
||||
/* res = analyze(tmp, x); */
|
||||
} else if (sexp_opcodep(op)) {
|
||||
res = sexp_length(ctx, sexp_cdr(x));
|
||||
if (sexp_unbox_fixnum(res) < sexp_opcode_num_args(op)) {
|
||||
|
|
@ -729,8 +719,10 @@ sexp sexp_analyze (sexp ctx, sexp object) {
|
|||
sexp_context_fv(tmp) = sexp_append2(tmp,
|
||||
sexp_synclo_free_vars(x),
|
||||
sexp_context_fv(tmp));
|
||||
if (sexp_pairp(sexp_synclo_free_vars(x)))
|
||||
sexp_debug(ctx, "free vars: ", sexp_context_fv(tmp));
|
||||
x = sexp_synclo_expr(x);
|
||||
res = sexp_analyze(tmp, x);
|
||||
res = analyze(tmp, x);
|
||||
} else {
|
||||
res = x;
|
||||
}
|
||||
|
|
@ -738,6 +730,10 @@ sexp sexp_analyze (sexp ctx, sexp object) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_analyze (sexp ctx, sexp x) {
|
||||
return analyze(ctx, x);
|
||||
}
|
||||
|
||||
static sexp_sint_t sexp_context_make_label (sexp ctx) {
|
||||
sexp_sint_t label = sexp_context_pos(ctx);
|
||||
sexp_context_pos(ctx) += sizeof(sexp_uint_t);
|
||||
|
|
@ -1233,12 +1229,14 @@ sexp sexp_vm (sexp ctx, sexp proc) {
|
|||
break;
|
||||
case OP_RAISE:
|
||||
call_error_handler:
|
||||
tmp1 = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE);
|
||||
if (! sexp_procedurep(tmp1)) goto end_loop;
|
||||
stack[top] = (sexp) 1;
|
||||
stack[top+1] = sexp_make_fixnum(ip-sexp_bytecode_data(bc));
|
||||
stack[top+2] = self;
|
||||
stack[top+3] = sexp_make_fixnum(fp);
|
||||
top += 4;
|
||||
self = sexp_env_global_ref(env, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), SEXP_FALSE);
|
||||
self = tmp1;
|
||||
bc = sexp_procedure_code(self);
|
||||
ip = sexp_bytecode_data(bc);
|
||||
cp = sexp_procedure_vars(self);
|
||||
|
|
@ -2183,6 +2181,7 @@ static struct sexp_struct core_forms[] = {
|
|||
{.tag=SEXP_CORE, .value={.core={CORE_IF, "if"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_BEGIN, "begin"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_QUOTE, "quote"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_SYNTAX_QUOTE, "syntax-quote"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_DEFINE_SYNTAX, "define-syntax"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_LET_SYNTAX, "let-syntax"}}},
|
||||
{.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}},
|
||||
|
|
@ -2334,7 +2333,7 @@ static sexp sexp_make_null_env (sexp ctx, sexp version) {
|
|||
|
||||
static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
||||
sexp_uint_t i;
|
||||
sexp ctx2, cell, sym, perr_cell, err_cell;
|
||||
sexp cell, sym;
|
||||
sexp_gc_var4(e, op, tmp, err_handler);
|
||||
sexp_gc_preserve4(ctx, e, op, tmp, err_handler);
|
||||
e = sexp_make_null_env(ctx, version);
|
||||
|
|
@ -2359,28 +2358,6 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) {
|
|||
sexp_c_string(ctx, sexp_module_dir, -1));
|
||||
sexp_env_define(ctx, e, sexp_intern(ctx, "*shared-object-extension*"),
|
||||
sexp_c_string(ctx, sexp_so_extension, -1));
|
||||
/* add default exception handler */
|
||||
err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL));
|
||||
perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception"));
|
||||
ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), e);
|
||||
sexp_context_tailp(ctx2) = 0;
|
||||
if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) {
|
||||
emit(ctx2, OP_GLOBAL_KNOWN_REF);
|
||||
emit_word(ctx2, (sexp_uint_t)err_cell);
|
||||
emit(ctx2, OP_LOCAL_REF);
|
||||
emit_word(ctx2, 0);
|
||||
emit(ctx2, OP_FCALL2);
|
||||
emit_word(ctx2, (sexp_uint_t)sexp_cdr(perr_cell));
|
||||
}
|
||||
emit_push(ctx2, SEXP_VOID);
|
||||
emit(ctx2, OP_DONE);
|
||||
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
|
||||
err_handler = sexp_make_procedure(ctx2,
|
||||
sexp_make_fixnum(0),
|
||||
sexp_make_fixnum(0),
|
||||
finalize_bytecode(ctx2),
|
||||
tmp);
|
||||
sexp_env_define(ctx2, e, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), err_handler);
|
||||
sexp_gc_release4(ctx);
|
||||
return e;
|
||||
}
|
||||
|
|
@ -2427,6 +2404,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
stack[top++] = sexp_make_fixnum(0);
|
||||
sexp_context_top(ctx) = top;
|
||||
res = sexp_vm(ctx, proc);
|
||||
if (! res) res = SEXP_VOID;
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
|
@ -2450,17 +2428,13 @@ sexp sexp_compile (sexp ctx, sexp x) {
|
|||
}
|
||||
|
||||
sexp sexp_eval (sexp ctx, sexp obj, sexp env) {
|
||||
sexp res, ctx2;
|
||||
sexp_gc_var1(thunk);
|
||||
sexp_gc_preserve1(ctx, thunk);
|
||||
sexp ctx2;
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
|
||||
thunk = sexp_compile(ctx2, obj);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx));
|
||||
res = thunk;
|
||||
} else {
|
||||
res = sexp_apply(ctx2, thunk, SEXP_NULL);
|
||||
}
|
||||
res = sexp_compile(ctx2, obj);
|
||||
if (! sexp_exceptionp(res))
|
||||
res = sexp_apply(ctx2, res, SEXP_NULL);
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ enum sexp_core_form_names {
|
|||
CORE_IF,
|
||||
CORE_BEGIN,
|
||||
CORE_QUOTE,
|
||||
CORE_SYNTAX_QUOTE,
|
||||
CORE_DEFINE_SYNTAX,
|
||||
CORE_LET_SYNTAX,
|
||||
CORE_LETREC_SYNTAX
|
||||
|
|
@ -128,8 +129,11 @@ SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
|
|||
SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
|
||||
SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env);
|
||||
SEXP_API sexp sexp_make_env (sexp context);
|
||||
SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value);
|
||||
SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls);
|
||||
SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
|
||||
SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
|
||||
SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
|
||||
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);
|
||||
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
|
||||
SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data);
|
||||
|
|
|
|||
52
init.scm
52
init.scm
|
|
@ -84,7 +84,10 @@
|
|||
(if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
|
||||
|
||||
(define (any pred ls)
|
||||
(if (pair? ls) (if (pred (car ls)) #t (any pred (cdr ls))) #f))
|
||||
(if (pair? ls) (if (pred (car ls)) (car ls) (any pred (cdr ls))) #f))
|
||||
|
||||
(define (every pred ls)
|
||||
(if (pair? ls) (if (pred (car ls)) (every pred (cdr ls)) #f) #t))
|
||||
|
||||
;; syntax
|
||||
|
||||
|
|
@ -200,21 +203,39 @@
|
|||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (identifier? (cadr expr))
|
||||
`(,(rename 'letrec) ((,(cadr expr)
|
||||
(,(rename 'lambda) ,(map car (caddr expr))
|
||||
,@(cdddr expr))))
|
||||
,(cons (cadr expr) (map cadr (caddr expr))))
|
||||
`((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr))
|
||||
,@(map cadr (cadr expr)))))))
|
||||
(if (null? (cdr expr)) (error "empty let" expr))
|
||||
(if (null? (cddr expr)) (error "no let body" expr))
|
||||
((lambda (bindings)
|
||||
(if (list? bindings) #f (error "bad let bindings"))
|
||||
(if (every (lambda (x)
|
||||
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
|
||||
bindings)
|
||||
(if (identifier? (cadr expr))
|
||||
`(,(rename 'letrec) ((,(cadr expr)
|
||||
(,(rename 'lambda) ,(map car bindings)
|
||||
,@(cdddr expr))))
|
||||
,(cons (cadr expr) (map cadr (caddr expr))))
|
||||
`((,(rename 'lambda) ,(map car bindings) ,@(cddr expr))
|
||||
,@(map cadr bindings)))
|
||||
(error "bad let syntax" expr)))
|
||||
(if (identifier? (cadr expr)) (caddr expr) (cadr expr))))))
|
||||
|
||||
(define-syntax let*
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr)) (error "empty let*" expr))
|
||||
(if (null? (cddr expr)) (error "no let* body" expr))
|
||||
(if (null? (cadr expr))
|
||||
`(,(rename 'begin) ,@(cddr expr))
|
||||
`(,(rename 'let) (,(caadr expr))
|
||||
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))))))
|
||||
(if (if (list? (cadr expr))
|
||||
(every
|
||||
(lambda (x)
|
||||
(if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
|
||||
(cadr expr))
|
||||
#f)
|
||||
`(,(rename 'let) (,(caadr expr))
|
||||
(,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))
|
||||
(error "bad let* syntax"))))))
|
||||
|
||||
(define-syntax case
|
||||
(er-macro-transformer
|
||||
|
|
@ -566,7 +587,7 @@
|
|||
(_cons (rename 'cons)) (_pair? (rename 'pair?))
|
||||
(_null? (rename 'null?)) (_expr (rename 'expr))
|
||||
(_rename (rename 'rename)) (_compare (rename 'compare))
|
||||
(_quote (rename 'quote)) (_apply (rename 'apply))
|
||||
(_quote (rename 'syntax-quote)) (_apply (rename 'apply))
|
||||
(_append (rename 'append)) (_map (rename 'map))
|
||||
(_vector? (rename 'vector?)) (_list? (rename 'list?))
|
||||
(_lp (rename 'lp)) (_reverse (rename 'reverse))
|
||||
|
|
@ -659,9 +680,10 @@
|
|||
(cdr x)))
|
||||
(define (all-vars x dim)
|
||||
(let lp ((x x) (dim dim) (vars '()))
|
||||
(cond ((identifier? x) (if (memq x (list _quote lits))
|
||||
vars
|
||||
(cons (cons x dim) vars)))
|
||||
(cond ((identifier? x)
|
||||
(if (any (lambda (lit) (compare x lit)) lits)
|
||||
vars
|
||||
(cons (cons x dim) vars)))
|
||||
((ellipse? x) (lp (car x) (+ dim 1) vars))
|
||||
((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
|
||||
((vector? x) (lp (vector->list x) dim vars))
|
||||
|
|
@ -683,7 +705,7 @@
|
|||
(cond
|
||||
((identifier? t)
|
||||
(cond
|
||||
((assq t vars)
|
||||
((any (lambda (v) (compare t (car v))) vars)
|
||||
=> (lambda (cell)
|
||||
(if (<= (cdr cell) dim)
|
||||
t
|
||||
|
|
|
|||
|
|
@ -25,15 +25,38 @@ static void sexp_define_accessors (sexp ctx, sexp env, sexp_uint_t ctype,
|
|||
sexp_gc_release2(ctx);
|
||||
}
|
||||
|
||||
static sexp sexp_get_env_cell (sexp ctx, sexp env, sexp id) {
|
||||
sexp cell = sexp_env_cell(env, id);
|
||||
while ((! cell) && sexp_synclop(id)) {
|
||||
env = sexp_synclo_env(id);
|
||||
id = sexp_synclo_expr(id);
|
||||
}
|
||||
return cell ? cell : SEXP_FALSE;
|
||||
}
|
||||
|
||||
static sexp sexp_get_opcode_name (sexp ctx, sexp op) {
|
||||
if (! sexp_opcodep(op))
|
||||
return sexp_type_exception(ctx, "not an opcode", op);
|
||||
else if (! sexp_opcode_name(op))
|
||||
return SEXP_FALSE;
|
||||
else
|
||||
return sexp_intern(ctx, sexp_opcode_name(op));
|
||||
}
|
||||
|
||||
sexp sexp_init_library (sexp ctx, sexp env) {
|
||||
sexp_gc_var2(name, op);
|
||||
sexp_gc_preserve2(ctx, name, op);
|
||||
sexp_define_type_predicate(ctx, env, "syntactic-closure?", SEXP_SYNCLO);
|
||||
sexp_define_type_predicate(ctx, env, "lambda?", SEXP_LAMBDA);
|
||||
sexp_define_type_predicate(ctx, env, "cnd?", SEXP_CND);
|
||||
sexp_define_type_predicate(ctx, env, "set?", SEXP_SET);
|
||||
sexp_define_type_predicate(ctx, env, "ref?", SEXP_REF);
|
||||
sexp_define_type_predicate(ctx, env, "seq?", SEXP_SEQ);
|
||||
sexp_define_type_predicate(ctx, env, "lit?", SEXP_LIT);
|
||||
sexp_define_type_predicate(ctx, env, "opcode?", SEXP_OPCODE);
|
||||
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 0, "syntactic-closure-env", "syntactic-closure-env-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 1, "syntactic-closure-vars", "syntactic-closure-vars-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_SYNCLO, 2, "syntactic-closure-expr", "syntactic-closure-expr-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 0, "lambda-name", "lambda-name-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 1, "lambda-params", "lambda-params-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_LAMBDA, 7, "lambda-body", "lambda-body-set!");
|
||||
|
|
@ -45,8 +68,11 @@ sexp sexp_init_library (sexp ctx, sexp env) {
|
|||
sexp_define_accessors(ctx, env, SEXP_REF, 0, "ref-name", "ref-name-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_REF, 1, "ref-cell", "ref-cell-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_SEQ, 0, "seq-ls", "seq-ls-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "list-value", "lit-value-set!");
|
||||
sexp_define_accessors(ctx, env, SEXP_LIT, 0, "lit-value", "lit-value-set!");
|
||||
sexp_define_foreign(ctx, env, "analyze", 1, sexp_analyze);
|
||||
sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
|
||||
sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
|
||||
sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
|
||||
sexp_gc_release2(ctx);
|
||||
return SEXP_VOID;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
|
||||
(define-module (chibi ast)
|
||||
(export analyze
|
||||
lambda? cnd? set? ref? seq? lit?
|
||||
(export analyze env-cell opcode-name
|
||||
syntactic-closure? lambda? cnd? set? ref? seq? lit? opcode?
|
||||
syntactic-closure-expr syntactic-closure-env syntactic-closure-vars
|
||||
lambda-name lambda-params lambda-body
|
||||
lambda-name-set! lambda-params-set! lambda-body-set!
|
||||
cnd-test cnd-pass cnd-fail
|
||||
set-var set-value
|
||||
ref-name ref-cell
|
||||
seq-ls
|
||||
lit-value)
|
||||
cnd-test-set! cnd-pass-set! cnd-fail-set!
|
||||
set-var set-value set-var-set! set-value-set!
|
||||
ref-name ref-cell ref-name-set! ref-cell-set!
|
||||
seq-ls seq-ls-set! lit-value lit-value-set!)
|
||||
(include-shared "ast"))
|
||||
|
||||
|
|
|
|||
10
lib/chibi/loop.module
Normal file
10
lib/chibi/loop.module
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
(define-module (chibi loop)
|
||||
(export loop in-list in-lists in-port in-file up-from down-from
|
||||
listing listing-reverse appending appending-reverse
|
||||
summing multiplying in-string in-string-reverse
|
||||
in-vector in-vector-reverse)
|
||||
(import (scheme))
|
||||
(import (chibi match))
|
||||
(include "loop.scm"))
|
||||
|
||||
404
lib/chibi/loop/loop.scm
Normal file
404
lib/chibi/loop/loop.scm
Normal file
|
|
@ -0,0 +1,404 @@
|
|||
;;;; loop.scm - the chibi loop (aka foof-loop)
|
||||
;;
|
||||
;; Copyright (c) 2009 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;; The loop API is compatible with Taylor Campbell's foof-loop, but
|
||||
;; the iterator API is different and subject to change. All loop
|
||||
;; variables may be implicitly destructured with MATCH semantics.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax let-keyword-form
|
||||
(syntax-rules ()
|
||||
((let-keyword-form
|
||||
((labeled-arg-macro-name
|
||||
(positional-form-name (arg-name . arg-default) ...)))
|
||||
. body)
|
||||
(letrec-syntax
|
||||
((labeled-arg-macro-name
|
||||
(syntax-rules ()
|
||||
((labeled-arg-macro-name . keyword-val-pairs)
|
||||
(letrec-syntax
|
||||
((find
|
||||
(syntax-rules (=> arg-name ...)
|
||||
((find kvp k-args (arg-name . default) (=> arg-name val)
|
||||
. others) ; found arg-name among keyword-val-pairs
|
||||
(next kvp val . k-args)) ...
|
||||
((find kvp k-args key (=> arg-no-match-name val) . others)
|
||||
(find kvp k-args key . others))
|
||||
;; default must be here
|
||||
((find kvp k-args (arg-name default))
|
||||
(next kvp default . k-args)) ...
|
||||
))
|
||||
(next ; pack the continuation to find
|
||||
(syntax-rules ()
|
||||
((next kvp val vals key . keys)
|
||||
(find kvp ((val . vals) . keys) key . kvp))
|
||||
((next kvp val vals) ; processed all arg-descriptors
|
||||
(rev-apply (val) vals))))
|
||||
(match-positionals
|
||||
(syntax-rules (=>)
|
||||
((match-positionals () res . rest)
|
||||
(rev-apply () res))
|
||||
((match-positionals args (val . vals) (=> name value)
|
||||
. rest)
|
||||
(next ((=> name value) . rest) val vals . args))
|
||||
((match-positionals args (val . vals))
|
||||
(next () val vals . args))
|
||||
((match-positionals (arg1 . args) res pos-arg . rest)
|
||||
(match-positionals args (pos-arg . res) . rest))))
|
||||
(rev-apply
|
||||
(syntax-rules ()
|
||||
((rev-apply form (x . xs))
|
||||
(rev-apply (x . form) xs))
|
||||
((rev-apply form ()) form))))
|
||||
(match-positionals ((arg-name . arg-default) ...)
|
||||
(positional-form-name)
|
||||
. keyword-val-pairs)
|
||||
)))))
|
||||
. body))))
|
||||
|
||||
;; (define-syntax let-keyword-form
|
||||
;; (syntax-rules ()
|
||||
;; ((let-keyword-form
|
||||
;; ((labeled-arg-macro-name (positional-name (arg default) ...)))
|
||||
;; . body)
|
||||
;; (letrec-syntax
|
||||
;; ((labeled-arg-macro-name
|
||||
;; (er-macro-transformer
|
||||
;; (lambda (expr rename compare)
|
||||
;; (receive (named posns)
|
||||
;; (partition (lambda (x) (and (list? x) (compare (car x) '=>)))
|
||||
;; (cdr expr))
|
||||
;; (let lp ((ls '((arg default) ...)) (posns posns) (args '()))
|
||||
;; (cond
|
||||
;; ((null? ls)
|
||||
;; (if (pair? posns)
|
||||
;; (error "let-keyword-form: too many args" expr)
|
||||
;; (cons 'positional-name (reverse args))))
|
||||
;; ((find (lambda (x) (compare (caar ls) (cadr x))) named)
|
||||
;; => (lambda (x)
|
||||
;; (lp (cdr ls) posns (cons (caddr x) args))))
|
||||
;; ((pair? posns)
|
||||
;; (lp (cdr ls) (cdr posns) (cons (car posns) args)))
|
||||
;; (else
|
||||
;; (lp (cdr ls) posns (cons (cadar ls) args))))))))))
|
||||
;; . body))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax loop
|
||||
(syntax-rules ()
|
||||
;; unnamed, implicit recursion
|
||||
((loop (vars ...) body ...)
|
||||
(%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
|
||||
;; named, explicit recursion
|
||||
((loop name (vars ...) body ...)
|
||||
(%loop name () () () () () (vars ...) body ...))))
|
||||
|
||||
;; Main LOOP macro. Separate the variables from the iterator and
|
||||
;; parameters, then walk through each parameter expanding the
|
||||
;; bindings, and build the final form.
|
||||
|
||||
(define-syntax %loop
|
||||
(syntax-rules (=> for with let while until)
|
||||
;; automatic iteration
|
||||
((_ name l v c r f ((for var1 (iterator source ...)) rest ...) . body)
|
||||
(iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
|
||||
((_ name l v c r f ((for var1 var2 (iterator source ...)) rest ...) . body)
|
||||
(iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
|
||||
((_ name l v c r f ((for var1 var2 var3 (iterator source ...)) rest ...) . body)
|
||||
(iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
|
||||
((_ name l v c r f ((for var1 var2 var3 var4 (iterator source ...)) rest ...) . body)
|
||||
(iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
|
||||
;; do equivalents, with optional guards
|
||||
((_ name l (vars ...) (checks ...) r f ((with var init step guard) rest ...) . body)
|
||||
(%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
|
||||
((_ name l (vars ...) c r f ((with var init step) rest ...) . body)
|
||||
(%loop name l (vars ... (var init step)) c r f (rest ...) . body))
|
||||
((_ name l (vars ...) c r f ((with var init) rest ...) . body)
|
||||
(%loop name l (vars ... (var init var)) c r f (rest ...) . body))
|
||||
;; user-specified terminators
|
||||
((_ name l vars (checks ...) r f ((until expr) rest ...) . body)
|
||||
(%loop name l vars (checks ... expr) r f (rest ...) . body))
|
||||
((_ name l vars (checks ...) r f ((while expr) rest ...) . body)
|
||||
(%loop name l vars (checks ... (not expr)) r f (rest ...) . body))
|
||||
;; specify a default done?
|
||||
((_ name l v c r f ())
|
||||
(%loop name l v c r f () (#f #f)))
|
||||
((_ name l v c r f () () . body)
|
||||
(%loop name l v c r f () (#f #f) . body))
|
||||
;; final expansion
|
||||
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
|
||||
=> result
|
||||
. body)
|
||||
(let* (lets ...)
|
||||
(letrec ((tmp (lambda (var ...)
|
||||
(if (or checks ...)
|
||||
(let-keyword-form ((name (tmp (var step) ...)))
|
||||
(match-let (finals ...) result))
|
||||
(match-let (refs ...)
|
||||
(let-keyword-form ((name (tmp (var step) ...)))
|
||||
(if #f #f)
|
||||
. body))))))
|
||||
(tmp init ...))))
|
||||
;; unspecified return value case
|
||||
((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
|
||||
. body)
|
||||
(%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
|
||||
=> (if #f #f) . body))
|
||||
))
|
||||
|
||||
(define-syntax %loop-next
|
||||
(syntax-rules ()
|
||||
((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
|
||||
name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
|
||||
. rest)
|
||||
(%loop name (lets ... new-lets ...) (vars ... new-vars ...)
|
||||
(checks ... new-checks ...) (refs ... new-refs ...)
|
||||
(finals ... new-finals ...)
|
||||
. rest))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Iterators
|
||||
|
||||
;; Each gets passed two lists, those items left of the <- and those to
|
||||
;; the right, followed by a NEXT and REST continuation.
|
||||
|
||||
;; Should finish with
|
||||
;;
|
||||
;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
|
||||
;; (loop-vars ...) (final-vars ...) . rest)
|
||||
;;
|
||||
;; OUTER-VARS: bound once outside the loop in a LET*
|
||||
;; CURSOR-VARS: DO-style bindings of the form (name init update)
|
||||
;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
|
||||
;; LOOP-VARS: inner variables, updated in parallel after the cursors
|
||||
;; FINAL-VARS: final variables, bound only in the => result
|
||||
|
||||
(define-syntax in-list ; called just "IN" in ITER
|
||||
(syntax-rules ()
|
||||
((in-list ((var) source) next . rest)
|
||||
(in-list ((var cursor) source) next . rest))
|
||||
((in-list ((var cursor) source) next . rest)
|
||||
(in-list ((var cursor succ) source) next . rest))
|
||||
((in-list ((var cursor succ) (source)) next . rest)
|
||||
(next () ; outer let bindings
|
||||
((cursor source succ)) ; iterator, init, step
|
||||
((not (pair? cursor))) ; finish tests for iterator vars
|
||||
;; step variables and values
|
||||
((var (car cursor))
|
||||
(succ (cdr cursor)))
|
||||
() ; final result bindings
|
||||
. rest))
|
||||
((in-list ((var cursor succ) (source step)) next . rest)
|
||||
(next ()
|
||||
((cursor source succ))
|
||||
((not (pair? cursor)))
|
||||
((var (car cursor))
|
||||
(succ (step cursor)))
|
||||
()
|
||||
. rest))))
|
||||
|
||||
;; Iterator from Taylor R. Campbell. If you know the number of lists
|
||||
;; ahead of time it's much more efficient to iterate over each one
|
||||
;; separately.
|
||||
(define-syntax in-lists
|
||||
(syntax-rules ()
|
||||
((in-lists ((elts) lol) next . rest)
|
||||
(in-lists ((elts pairs) lol) next . rest))
|
||||
((in-lists ((elts pairs) lol) next . rest)
|
||||
(in-lists ((elts pairs succ) lol) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol cdr)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol step)) next . rest)
|
||||
(in-lists ((elts pairs succ) (lol step null?)) next . rest))
|
||||
((in-lists ((elts pairs succ) (lol step done?)) next . rest)
|
||||
(next ()
|
||||
((pairs lol succ))
|
||||
((let lp ((ls pairs)) ; an in-lined ANY
|
||||
(and (pair? ls) (if (done? (car ls)) #t (lp (cdr ls))))))
|
||||
((elts (map car pairs))
|
||||
(succ (map step pairs)))
|
||||
()
|
||||
. rest))
|
||||
))
|
||||
|
||||
(define-syntax define-in-indexed
|
||||
(syntax-rules ()
|
||||
((define-in-indexed in-type in-type-reverse length ref)
|
||||
(begin
|
||||
(define-syntax in-type
|
||||
(syntax-rules ()
|
||||
((in-type ls next . rest)
|
||||
(%in-idx >= + 0 (length tmp) ref tmp ls next . rest))))
|
||||
(define-syntax in-type-reverse
|
||||
(syntax-rules ()
|
||||
((in-type-reverse ls next . rest)
|
||||
(%in-idx < - (- (length tmp) 1) 0 ref tmp ls next . rest))))
|
||||
))))
|
||||
|
||||
(define-in-indexed in-string in-string-reverse string-length string-ref)
|
||||
(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
|
||||
|
||||
;; helper for the above string and vector iterators
|
||||
(define-syntax %in-idx
|
||||
(syntax-rules ()
|
||||
;; cmp inc start end ref
|
||||
((%in-idx ge + s e r tmp-vec ((var) (vec ...)) next . rest)
|
||||
(%in-idx ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
|
||||
((%in-idx ge + s e r tmp-vec ((var index) (vec)) next . rest)
|
||||
(%in-idx ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
|
||||
((%in-idx ge + s e r tmp-vec ((var index) (vec from)) next . rest)
|
||||
(%in-idx ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
|
||||
((%in-idx ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
|
||||
(%in-idx ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
|
||||
((%in-idx ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
|
||||
(next ((tmp-vec vec) (end to))
|
||||
((index from (+ index step)))
|
||||
((ge index end))
|
||||
((var (r tmp-vec index)))
|
||||
()
|
||||
. rest))
|
||||
))
|
||||
|
||||
(define-syntax in-port
|
||||
(syntax-rules ()
|
||||
((in-port ((var) source) next . rest)
|
||||
(in-port ((var p) source) next . rest))
|
||||
((in-port ((var p) ()) next . rest)
|
||||
(in-port ((var p) ((current-input-port))) next . rest))
|
||||
((in-port ((var p) (port)) next . rest)
|
||||
(in-port ((var p) (port read-char)) next . rest))
|
||||
((in-port ((var p) (port read-char)) next . rest)
|
||||
(in-port ((var p) (port read-char eof-object?)) next . rest))
|
||||
((in-port ((var p) (port reader eof?)) next . rest)
|
||||
(next ((p port) (r reader) (e? eof?))
|
||||
((var (r p) (r p)))
|
||||
((e? var))
|
||||
()
|
||||
()
|
||||
. rest))))
|
||||
|
||||
(define-syntax in-file
|
||||
(syntax-rules ()
|
||||
((in-file ((var) source) next . rest)
|
||||
(in-file ((var p) source) next . rest))
|
||||
((in-file ((var p) (file)) next . rest)
|
||||
(in-file ((var p) (file read-char)) next . rest))
|
||||
((in-file ((var p) (file reader)) next . rest)
|
||||
(in-file ((var p) (file reader eof-object?)) next . rest))
|
||||
((in-file ((var p) (file reader eof?)) next . rest)
|
||||
(next ((p (open-input-file file)) (r reader) (e? eof?))
|
||||
((var (r p) (r p)))
|
||||
((e? var))
|
||||
()
|
||||
((dummy (close-input-port p)))
|
||||
. rest))))
|
||||
|
||||
(define-syntax up-from
|
||||
(syntax-rules (to by)
|
||||
((up-from (() . args) next . rest)
|
||||
(up-from ((var) . args) next . rest))
|
||||
((up-from ((var) (start (to limit) (by step))) next . rest)
|
||||
(next ((s start) (l limit) (e step))
|
||||
((var s (+ var e)))
|
||||
((>= var l))
|
||||
()
|
||||
()
|
||||
. rest))
|
||||
((up-from ((var) (start (to limit))) next . rest)
|
||||
(next ((s start) (l limit))
|
||||
((var s (+ var 1)))
|
||||
((>= var l))
|
||||
()
|
||||
()
|
||||
. rest))
|
||||
((up-from ((var) (start (by step))) next . rest)
|
||||
(next ((s start) (e step)) ((var s (+ var e))) () () () . rest))
|
||||
((up-from ((var) (start)) next . rest)
|
||||
(next ((s start)) ((var s (+ var 1))) () () () . rest))
|
||||
))
|
||||
|
||||
(define-syntax down-from
|
||||
(syntax-rules (to by)
|
||||
((down-from (() . args) next . rest)
|
||||
(down-from ((var) . args) next . rest))
|
||||
((down-from ((var) (start (to limit) (by step))) next . rest)
|
||||
(next ((s start) (l limit) (e step))
|
||||
((var (- s e) (- var e)))
|
||||
((< var l))
|
||||
()
|
||||
()
|
||||
. rest))
|
||||
((down-from ((var) (start (to limit))) next . rest)
|
||||
(next ((s start) (l limit))
|
||||
((var (- s 1) (- var 1)))
|
||||
((< var l))
|
||||
()
|
||||
()
|
||||
. rest))
|
||||
((down-from ((var) (start (by step))) next . rest)
|
||||
(next ((s start) (e step)) ((var (- s e) (- var e))) () () ()
|
||||
. rest))
|
||||
((down-from ((var) (start)) next . rest)
|
||||
(next ((s start)) ((var (- s 1) (- var 1))) () () ()
|
||||
. rest))
|
||||
))
|
||||
|
||||
(define-syntax accumulating
|
||||
(syntax-rules (initial if)
|
||||
((accumulating (kons final init) ((var) . x) next . rest)
|
||||
(accumulating (kons final init) ((var cursor) . x) next . rest))
|
||||
((accumulating (kons final init) ((var cursor) ((initial i) . x)) n . rest)
|
||||
(accumulating (kons final i) ((var cursor) x) n . rest))
|
||||
((accumulating (kons final init) ((var cursor) (expr (if check))) n . rest)
|
||||
(n ((tmp-kons kons))
|
||||
((cursor '() (if check (tmp-kons expr cursor) cursor)))
|
||||
()
|
||||
()
|
||||
((var (final cursor)))
|
||||
. rest))
|
||||
((accumulating (kons final init) ((var cursor) (expr)) n . rest)
|
||||
(n ((tmp-kons kons))
|
||||
((cursor '() (tmp-kons expr cursor)))
|
||||
()
|
||||
()
|
||||
((var (final cursor)))
|
||||
. rest))))
|
||||
|
||||
(define-syntax listing
|
||||
(syntax-rules ()
|
||||
((listing args next . rest)
|
||||
(accumulating (cons reverse '()) args next . rest))))
|
||||
|
||||
(define-syntax listing-reverse
|
||||
(syntax-rules ()
|
||||
((listing-reverse args next . rest)
|
||||
(accumulating (cons (lambda (x) x) '()) args next . rest))))
|
||||
|
||||
(define (append-reverse ls1 ls2)
|
||||
(append (reverse ls1) ls2))
|
||||
|
||||
(define-syntax appending
|
||||
(syntax-rules ()
|
||||
((appending args next . rest)
|
||||
(accumulating (append-reverse reverse '()) args next . rest))))
|
||||
|
||||
(define-syntax appending-reverse
|
||||
(syntax-rules ()
|
||||
((appending-reverse args next . rest)
|
||||
(accumulating (append-reverse (lambda (x) x) '()) args next . rest))))
|
||||
|
||||
(define-syntax summing
|
||||
(syntax-rules ()
|
||||
((summing args next . rest)
|
||||
(accumulating (+ (lambda (x) x) 0) args next . rest))))
|
||||
|
||||
(define-syntax multiplying
|
||||
(syntax-rules ()
|
||||
((multiplying args next . rest)
|
||||
(accumulating (* (lambda (x) x) 1) args next . rest))))
|
||||
29
main.c
29
main.c
|
|
@ -112,18 +112,32 @@ void repl (sexp ctx) {
|
|||
tmp = sexp_env_bindings(env);
|
||||
sexp_context_top(ctx) = 0;
|
||||
res = sexp_eval(ctx, obj, env);
|
||||
if (sexp_exceptionp(res)) {
|
||||
sexp_print_exception(ctx, res, err);
|
||||
} else {
|
||||
#if USE_WARN_UNDEFS
|
||||
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
|
||||
sexp_warn_undefs(ctx, sexp_env_bindings(env), tmp, err);
|
||||
#endif
|
||||
if (res != SEXP_VOID) {
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
if (res != SEXP_VOID) {
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
sexp_gc_release4(ctx);
|
||||
}
|
||||
|
||||
sexp check_exception (sexp ctx, sexp res) {
|
||||
if (res && sexp_exceptionp(res)) {
|
||||
sexp_print_exception(ctx, res,
|
||||
sexp_eval_string(ctx, "(current-error-port)",
|
||||
sexp_context_env(ctx)));
|
||||
exit(EXIT_FAILURE);
|
||||
}
|
||||
return res;
|
||||
}
|
||||
|
||||
void run_main (int argc, char **argv) {
|
||||
sexp env, out=NULL, res=SEXP_VOID, ctx;
|
||||
sexp_sint_t i, quit=0, init_loaded=0;
|
||||
|
|
@ -179,14 +193,11 @@ void run_main (int argc, char **argv) {
|
|||
|
||||
if (! quit) {
|
||||
if (! init_loaded)
|
||||
res = sexp_init_environments(ctx);
|
||||
res = check_exception(ctx, sexp_init_environments(ctx));
|
||||
sexp_env_define(ctx, env, sexp_intern(ctx, "*command-line-arguments*"), args);
|
||||
if (res && sexp_exceptionp(res))
|
||||
sexp_print_exception(ctx, res,
|
||||
sexp_eval_string(ctx, "(current-error-port)", env));
|
||||
if (i < argc)
|
||||
for ( ; i < argc; i++)
|
||||
res = sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env);
|
||||
res = check_exception(ctx, sexp_load(ctx, str=sexp_c_string(ctx, argv[i], -1), env));
|
||||
else
|
||||
repl(ctx);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -37,26 +37,12 @@
|
|||
(write (let ((tmp 6)) (myor #f tmp)))
|
||||
(newline)
|
||||
|
||||
;; (let ((x 'outer))
|
||||
;; (let-syntax ((with-x
|
||||
;; (syntax-rules ()
|
||||
;; ((_ y expr)
|
||||
;; (let-syntax ((y (syntax-rules () ((_) x))))
|
||||
;; expr)))))
|
||||
;; (let ((x 'inner))
|
||||
;; (write (with-x z (z)))
|
||||
;; (newline))))
|
||||
|
||||
(let ((x 'outer))
|
||||
(let-syntax ((with-x
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
`(let-syntax ((,(cadr form)
|
||||
(er-macro-transformer
|
||||
(lambda (form rename2 compare)
|
||||
(rename2 'x)))))
|
||||
,(caddr form))))))
|
||||
(syntax-rules ()
|
||||
((_ y expr)
|
||||
(let-syntax ((y (syntax-rules () ((_) x))))
|
||||
expr)))))
|
||||
(let ((x 'inner))
|
||||
(write (with-x z (z)))
|
||||
(newline))))
|
||||
|
||||
|
|
|
|||
202
tests/loop-tests.scm
Normal file
202
tests/loop-tests.scm
Normal file
|
|
@ -0,0 +1,202 @@
|
|||
|
||||
(import (chibi loop))
|
||||
|
||||
(define *tests-run* 0)
|
||||
(define *tests-passed* 0)
|
||||
|
||||
(define-syntax test
|
||||
(syntax-rules ()
|
||||
((test name expr expect)
|
||||
(begin
|
||||
(set! *tests-run* (+ *tests-run* 1))
|
||||
(let ((str (call-with-output-string (lambda (out) (display name out))))
|
||||
(res expr))
|
||||
(display str)
|
||||
(write-char #\space)
|
||||
(display (make-string (max 0 (- 72 (string-length str))) #\.))
|
||||
(flush-output)
|
||||
(cond
|
||||
((equal? res expect)
|
||||
(set! *tests-passed* (+ *tests-passed* 1))
|
||||
(display " [PASS]\n"))
|
||||
(else
|
||||
(display " [FAIL]\n")
|
||||
(display " expected ") (write expect)
|
||||
(display " but got ") (write res) (newline))))))))
|
||||
|
||||
(define (test-report)
|
||||
(write *tests-passed*)
|
||||
(display " out of ")
|
||||
(write *tests-run*)
|
||||
(display " passed (")
|
||||
(write (* (/ *tests-passed* *tests-run*) 100))
|
||||
(display "%)")
|
||||
(newline))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; run tests
|
||||
|
||||
(test
|
||||
"stepping"
|
||||
'(0 1 2)
|
||||
(loop lp ((with i 0 (+ i 1))
|
||||
(with res '() (cons i res)))
|
||||
(if (= i 3)
|
||||
(reverse res)
|
||||
(lp))))
|
||||
|
||||
(test
|
||||
"basic in-list"
|
||||
'(c b a)
|
||||
(let ((res '()))
|
||||
(loop ((for x (in-list '(a b c))))
|
||||
(set! res (cons x res)))
|
||||
res))
|
||||
|
||||
(test
|
||||
"in-list with result"
|
||||
'(c b a)
|
||||
(loop ((for x (in-list '(a b c)))
|
||||
(with res '() (cons x res)))
|
||||
=> res))
|
||||
|
||||
(test
|
||||
"in-list with listing"
|
||||
'(a b c)
|
||||
(loop ((for x (in-list '(a b c))) (for res (listing x))) => res))
|
||||
|
||||
(test
|
||||
"in-list with listing-reverse"
|
||||
'(c b a)
|
||||
(loop ((for x (in-list '(a b c))) (for res (listing-reverse x))) => res))
|
||||
|
||||
(test
|
||||
"uneven length in-list's"
|
||||
'((a . 1) (b . 2) (c . 3))
|
||||
(loop ((for x (in-list '(a b c)))
|
||||
(for y (in-list '(1 2 3 4)))
|
||||
(for res (listing (cons x y))))
|
||||
=> res))
|
||||
|
||||
(test
|
||||
"in-lists"
|
||||
'((a 1) (b 2) (c 3))
|
||||
(loop ((for ls (in-lists '((a b c) (1 2 3))))
|
||||
(for res (listing ls)))
|
||||
=> res))
|
||||
|
||||
(define (flatten ls)
|
||||
(reverse
|
||||
(loop lp ((for x ls (in-list ls)) (with res '()))
|
||||
=> res
|
||||
(if (pair? x)
|
||||
(lp (=> res (lp (=> ls x))))
|
||||
(lp (=> res (cons x res)))))))
|
||||
|
||||
(test
|
||||
"flatten (recursion test)"
|
||||
'(1 2 3 4 5 6 7)
|
||||
(flatten '(1 (2) (3 (4 (5)) 6) 7)))
|
||||
|
||||
(test
|
||||
"in-string"
|
||||
'(#\h #\e #\l #\l #\o)
|
||||
(loop ((for c (in-string "hello")) (for res (listing c))) => res))
|
||||
|
||||
(test
|
||||
"in-string with start"
|
||||
'(#\l #\o)
|
||||
(loop ((for c (in-string "hello" 3)) (for res (listing c))) => res))
|
||||
|
||||
(test
|
||||
"in-string with start and end"
|
||||
'(#\h #\e #\l #\l)
|
||||
(loop ((for c (in-string "hello" 0 4)) (for res (listing c))) => res))
|
||||
|
||||
(test
|
||||
"in-string with start, end and step"
|
||||
'(#\e #\l)
|
||||
(loop ((for c (in-string "hello" 1 4 2)) (for res (listing c))) => res))
|
||||
|
||||
(test
|
||||
"in-string-reverse"
|
||||
'(#\o #\l #\l #\e #\h)
|
||||
(loop ((for c (in-string-reverse "hello")) (for res (listing c))) => res))
|
||||
|
||||
(test
|
||||
"in-vector"
|
||||
'(1 2 3)
|
||||
(loop ((for x (in-vector '#(1 2 3))) (for res (listing x))) => res))
|
||||
|
||||
(test "up-from" '(5 6 7)
|
||||
(loop ((for i (up-from 5 (to 8)))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "up-from by" '(5 10 15)
|
||||
(loop ((for i (up-from 5 (to 20) (by 5)))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "up-from listing if" '(10 12 14 16 18)
|
||||
(loop ((for i (up-from 10 (to 20)))
|
||||
(for res (listing i (if (even? i)))))
|
||||
=> res))
|
||||
|
||||
(test "down-from" '(7 6 5)
|
||||
(loop ((for i (down-from 8 (to 5)))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "down-from by" '(15 10 5)
|
||||
(loop ((for i (down-from 20 (to 5) (by 5)))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "down-from listing if" '(18 16 14 12 10)
|
||||
(loop ((for i (down-from 20 (to 10)))
|
||||
(for res (listing i (if (even? i)))))
|
||||
=> res))
|
||||
|
||||
(test "appending" '(1 2 3 4 5 6 7 8 9)
|
||||
(loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
|
||||
(for res (appending ls)))
|
||||
=> res))
|
||||
|
||||
(test "appending-reverse" '(9 8 7 6 5 4 3 2 1)
|
||||
(loop ((for ls (in-list '((1 2 3) (4 5 6) (7 8 9))))
|
||||
(for res (appending-reverse ls)))
|
||||
=> res))
|
||||
|
||||
(test "while + up-from" '(5 6 7)
|
||||
(loop ((for i (up-from 5 (to 10)))
|
||||
(while (< i 8))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "up-from by, open-ended" '(5 7 9)
|
||||
(loop ((for i (up-from 5 (by 2)))
|
||||
(while (< i 10))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "up-from open-ended" '(5 6 7)
|
||||
(loop ((for i (up-from 5))
|
||||
(while (< i 8))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "down-from by, open-ended" '(5 3 1)
|
||||
(loop ((for i (down-from 7 (by 2)))
|
||||
(until (< i 1))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test "down-from open-ended" '(4 3 2)
|
||||
(loop ((for i (down-from 5))
|
||||
(until (< i 2))
|
||||
(for res (listing i)))
|
||||
=> res))
|
||||
|
||||
(test-report)
|
||||
|
||||
Loading…
Add table
Reference in a new issue