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

@@ -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
 

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

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));
+    test = analyze(ctx, sexp_cadr(x));
-    pass = sexp_analyze(ctx, sexp_caddr(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 ctx2;
-  sexp_gc_var1(thunk);
+  sexp_gc_var1(res);
-  sexp_gc_preserve1(ctx, thunk);
+  sexp_gc_preserve1(ctx, res);
   ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx)));
-  thunk = sexp_compile(ctx2, obj);
+  res = sexp_compile(ctx2, obj);
-  if (sexp_exceptionp(thunk)) {
+  if (! sexp_exceptionp(res))
-    sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx));
+    res = sexp_apply(ctx2, res, SEXP_NULL);
-    res = thunk;
-  } else {
-    res = sexp_apply(ctx2, thunk, SEXP_NULL);
-  }
   sexp_gc_release1(ctx);
   return res;
 }

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);

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 (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 (caddr expr))
+                                      (,(rename 'lambda) ,(map car bindings)
                                        ,@(cdddr expr))))
                   ,(cons (cadr expr) (map cadr (caddr expr))))
-         `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr))
+                `((,(rename 'lambda) ,(map car bindings) ,@(cddr expr))
-           ,@(map cadr (cadr 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))
+         (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)))))))
+               (,(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,7 +680,8 @@
              (cdr x)))
        (define (all-vars x dim)
          (let lp ((x x) (dim dim) (vars '()))
-           (cond ((identifier? x) (if (memq x (list _quote lits))
+           (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))
@@ -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

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;
 }

lib/chibi/ast.module

@@ -1,12 +1,14 @@
 
 (define-module (chibi ast)
-  (export analyze
+  (export analyze env-cell opcode-name
-          lambda? cnd? set? ref? seq? lit?
+          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
+          cnd-test-set! cnd-pass-set! cnd-fail-set!
-          ref-name ref-cell
+          set-var set-value set-var-set! set-value-set!
-          seq-ls
+          ref-name ref-cell ref-name-set! ref-cell-set!
-          lit-value)
+          seq-ls seq-ls-set! lit-value lit-value-set!)
   (include-shared "ast"))
 

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"))
+

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))))

main.c

@@ -112,6 +112,9 @@ 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);
 #endif
@@ -121,9 +124,20 @@ void repl (sexp ctx) {
         }
       }
     }
+  }
   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);
   }

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
+                (syntax-rules ()
-                 (lambda (form rename compare)
+                  ((_ y expr)
-                   `(let-syntax ((,(cadr form)
+                   (let-syntax ((y (syntax-rules () ((_) x))))
-                                  (er-macro-transformer
+                     expr)))))
-                                   (lambda (form rename2 compare)
-                                     (rename2 'x)))))
-                      ,(caddr form))))))
     (let ((x 'inner))
       (write (with-x z (z)))
       (newline)))) 
-

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)
+