From 0efd491c24bff9919f68d61781f9353a963c9fba Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 6 Dec 2009 17:40:50 +0900 Subject: [PATCH] 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 --- Makefile | 3 + config.scm | 2 +- eval.c | 112 ++++----- include/chibi/eval.h | 4 + init.scm | 52 +++-- lib/chibi/ast.c | 28 ++- lib/chibi/ast.module | 14 +- lib/chibi/loop.module | 10 + lib/chibi/loop/loop.scm | 404 +++++++++++++++++++++++++++++++++ main.c | 29 ++- tests/basic/test09-hygiene.scm | 22 +- tests/loop-tests.scm | 202 +++++++++++++++++ 12 files changed, 763 insertions(+), 119 deletions(-) create mode 100644 lib/chibi/loop.module create mode 100644 lib/chibi/loop/loop.scm create mode 100644 tests/loop-tests.scm diff --git a/Makefile b/Makefile index d8099808..02e20cb9 100644 --- a/Makefile +++ b/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 diff --git a/config.scm b/config.scm index dc54b1fd..1267bd81 100644 --- a/config.scm +++ b/config.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 diff --git a/eval.c b/eval.c index 49fd8a31..a5e46b5d 100644 --- a/eval.c +++ b/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; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 1326333e..7009a29a 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -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); diff --git a/init.scm b/init.scm index c457e8b9..a1038829 100644 --- a/init.scm +++ b/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 diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c index 62779b54..c3391a64 100644 --- a/lib/chibi/ast.c +++ b/lib/chibi/ast.c @@ -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; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index c487aa37..d95b97d5 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -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")) diff --git a/lib/chibi/loop.module b/lib/chibi/loop.module new file mode 100644 index 00000000..24c5397c --- /dev/null +++ b/lib/chibi/loop.module @@ -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")) + diff --git a/lib/chibi/loop/loop.scm b/lib/chibi/loop/loop.scm new file mode 100644 index 00000000..0c7cc4a5 --- /dev/null +++ b/lib/chibi/loop/loop.scm @@ -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)))) diff --git a/main.c b/main.c index 151e5d86..07e6207a 100644 --- a/main.c +++ b/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); } diff --git a/tests/basic/test09-hygiene.scm b/tests/basic/test09-hygiene.scm index 4ec53fe3..820020c1 100644 --- a/tests/basic/test09-hygiene.scm +++ b/tests/basic/test09-hygiene.scm @@ -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)))) - diff --git a/tests/loop-tests.scm b/tests/loop-tests.scm new file mode 100644 index 00000000..1c49d48f --- /dev/null +++ b/tests/loop-tests.scm @@ -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) +