store difference between ip and bytecode start instead of the

raw ip, which may overflow the integer range.

.hgignore

@@ -4,6 +4,7 @@ syntax: glob
 *.s
 *.o
 *.so
+*.dylib
 *.dSYM
 *.orig
 .hg

Makefile

@@ -37,14 +37,14 @@ endif
 
 ifdef USE_BOEHM
 GCLDFLAGS := -lgc
-CPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1
+XCPPFLAGS := $(CPPFLAGS) -Iinclude -DUSE_BOEHM=1
 else
 GCLDFLAGS :=
-CPPFLAGS := $(CPPFLAGS) -Iinclude
+XCPPFLAGS := $(CPPFLAGS) -Iinclude
 endif
 
-LDFLAGS  := $(LDFLAGS) -lm
+XLDFLAGS  := $(LDFLAGS) $(GCLDFLAGS) -lm
-CFLAGS   := $(CFLAGS) -Wall -O2 -g
+XCFLAGS   := $(CFLAGS) -Wall -O2 -g
 
 INCLUDES = include/chibi/sexp.h include/chibi/config.h include/chibi/install.h
 
@@ -52,22 +52,22 @@ include/chibi/install.h: Makefile
 	echo '#define sexp_module_dir "'$(MODDIR)'"' > $@
 
 sexp.o: sexp.c gc.c $(INCLUDES) Makefile
-	$(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
 eval.o: eval.c debug.c opcodes.c include/chibi/eval.h $(INCLUDES) Makefile
-	$(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
 main.o: main.c $(INCLUDES) Makefile
-	$(CC) -c $(CPPFLAGS) $(CFLAGS) -o $@ $<
+	$(CC) -c $(XCPPFLAGS) $(XCFLAGS) -o $@ $<
 
 libchibi-scheme$(SO): eval.o sexp.o
-	$(CC) $(CLIBFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS)
+	$(CC) $(CLIBFLAGS) -o $@ $^ $(XLDFLAGS)
 
 chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
-	$(CC) $(CPPFLAGS) $(CFLAGS) -o $@ $< -L. -lchibi-scheme
+	$(CC) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
 
 chibi-scheme-static$(EXE): main.o eval.o sexp.o
-	$(CC) $(CFLAGS) $(STATICFLAGS) -o $@ $^ $(LDFLAGS) $(GCLDFLAGS)
+	$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
 
 clean:
 	rm -f *.o *.i *.s
@@ -87,12 +87,12 @@ test-basic: chibi-scheme
 	done
 
 test: chibi-scheme
-	./chibi-scheme -l syntax-rules.scm tests/r5rs-tests.scm
+	./chibi-scheme tests/r5rs-tests.scm
 
 install: chibi-scheme
 	cp chibi-scheme $(BINDIR)/
 	mkdir -p $(MODDIR)
-	cp init.scm syntax-rules.scm $(MODDIR)/
+	cp init.scm $(MODDIR)/
 	mkdir -p $(INCDIR)
 	cp $(INCLUDES) include/chibi/eval.h $(INCDIR)/
 	mkdir -p $(LIBDIR)

README

@@ -2,7 +2,7 @@
                              Chibi-Scheme
                             --------------
                                    
-               Simple and Minimal Scheme Implementation
+    Minimal Scheme Implementation for use as an Extension Language
 
               http://synthcode.com/wiki/chibi-scheme/
 
@@ -15,9 +15,38 @@ macros based on syntactic-closures, string ports and exceptions.
 Chibi-Scheme is written in highly portable C and supports multiple
 simultaneous VM instances to run.
 
-To build, just run "make".  You can edit the file config.h for a
+To build, just run "make".  This will provide a shared library
-number of settings, mostly disabling features to make the executable
+"libchibi-scheme", as well as a sample "chibi-scheme" command-line
-smaller.  Documents and examples for using Chibi-Scheme as a library
+repl.  The "chibi-scheme-static" make target builds an equivalent
-for extension scripting will be provided in an upcoming release.
+static executable.
+
+You can edit the file config.h for a number of settings, mostly
+disabling features to make the executable smaller.  You can specify
+standard options directly as arguments to make, for example
+
+  make CFLAGS=-Os
+
+to optimize for size, or
+
+  make LDFLAGS=-L/usr/local/lib CPPFLAGS=-I/usr/local/include
+
+to compile against a library installed in /usr/local.
+
+By default Chibi uses a custom, precise, non-moving GC.  You can link
+against the Boehm conservative GC by editing the config file, or
+directly from make with:
+
+  make USE_BOEHM=1
+
+See the file main.c for an example of using chibi-scheme as a library.
+The essential functions to remember are:
+
+  sexp_make_context(NULL, NULL, NULL)
+    returns a new context
+
+  sexp_eval(context, expr)
+    evaluates an s-expression
+
+  sexp_eval_string(context, str)
+    reads an s-expression from str and evaluates it
 
-syntax-rules must be loaded manually from the file syntax-rules.scm.

eval.c

@@ -1245,7 +1245,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
   case OP_RAISE:
   call_error_handler:
     stack[top] = (sexp) 1;
-    stack[top+1] = sexp_make_integer(ip);
+    stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc));
     stack[top+2] = self;
     stack[top+3] = sexp_make_integer(fp);
     top += 4;
@@ -1269,7 +1269,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     break;
   case OP_CALLCC:
     stack[top] = sexp_make_integer(1);
-    stack[top+1] = sexp_make_integer(ip);
+    stack[top+1] = sexp_make_integer(ip-sexp_bytecode_data(bc));
     stack[top+2] = self;
     stack[top+3] = sexp_make_integer(fp);
     tmp1 = _ARG1;
@@ -1298,10 +1298,11 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     /* save frame info */
     tmp2 = stack[fp+3];
     j = sexp_unbox_integer(stack[fp]);
-    ip = ((unsigned char*) sexp_unbox_integer(stack[fp+1])) - sizeof(sexp);
     self = stack[fp+2];
-    cp = sexp_procedure_vars(self);
     bc = sexp_procedure_vars(self);
+    cp = sexp_procedure_vars(self);
+    ip = (sexp_bytecode_data(bc)
+          + sexp_unbox_integer(stack[fp+1])) - sizeof(sexp);
     /* copy new args into place */
     for (k=0; k<i; k++)
       stack[fp-j+k] = stack[top-1-i+k];
@@ -1355,7 +1356,7 @@ sexp sexp_vm (sexp ctx, sexp proc) {
       i++;
     }
     _ARG1 = sexp_make_integer(i);
-    stack[top] = sexp_make_integer(ip+sizeof(sexp));
+    stack[top] = sexp_make_integer(ip+sizeof(sexp)-sexp_bytecode_data(bc));
     stack[top+1] = self;
     stack[top+2] = sexp_make_integer(fp);
     top += 3;
@@ -1775,9 +1776,9 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     i = sexp_unbox_integer(stack[fp]);
     stack[fp-i] = _ARG1;
     top = fp-i+1;
-    ip = (unsigned char*) sexp_unbox_integer(stack[fp+1]);
     self = stack[fp+2];
     bc = sexp_procedure_code(self);
+    ip = sexp_bytecode_data(bc) + sexp_unbox_integer(stack[fp+1]);
     cp = sexp_procedure_vars(self);
     fp = sexp_unbox_integer(stack[fp+3]);
     break;
@@ -2077,8 +2078,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   stack[top] = sexp_make_integer(top);
   top++;
   sexp_context_top(ctx) = top + 3;
-  stack[top++] = sexp_make_integer(sexp_bytecode_data(final_resumer));
+  stack[top++] = sexp_make_integer(0);
-  stack[top++] = sexp_make_vector(ctx, 0, SEXP_VOID);
+  stack[top++] = final_resumer;
   stack[top++] = sexp_make_integer(0);
   return sexp_vm(ctx, proc);
 }
@@ -2160,6 +2161,10 @@ void sexp_scheme_init () {
     continuation_resumer = finalize_bytecode(ctx);
     ctx = sexp_make_child_context(ctx, NULL);
     emit(ctx, OP_DONE);
-    final_resumer = finalize_bytecode(ctx);
+    final_resumer = sexp_make_procedure(ctx,
+                                        sexp_make_integer(0),
+                                        sexp_make_integer(0),
+                                        finalize_bytecode(ctx),
+                                        sexp_make_vector(ctx, 0, SEXP_VOID));
   }
 }

include/chibi/sexp.h

@@ -326,11 +326,11 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_make_boolean(x) ((x) ? SEXP_TRUE : SEXP_FALSE)
 #define sexp_unbox_boolean(x) (((x) == SEXP_FALSE) ? 0 : 1)
 
-#define sexp_make_integer(n)    ((sexp) ((((sexp_sint_t)n)<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
+#define sexp_make_integer(n)    ((sexp) ((((sexp_sint_t)(n))<<SEXP_FIXNUM_BITS) + SEXP_FIXNUM_TAG))
-#define sexp_unbox_integer(n)   (((sexp_sint_t)n)>>SEXP_FIXNUM_BITS)
+#define sexp_unbox_integer(n)   (((sexp_sint_t)(n))>>SEXP_FIXNUM_BITS)
 
-#define sexp_make_character(n)  ((sexp) ((((sexp_sint_t)n)<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
+#define sexp_make_character(n)  ((sexp) ((((sexp_sint_t)(n))<<SEXP_EXTENDED_BITS) + SEXP_CHAR_TAG))
-#define sexp_unbox_character(n) ((int) (((sexp_sint_t)n)>>SEXP_EXTENDED_BITS))
+#define sexp_unbox_character(n) ((int) (((sexp_sint_t)(n))>>SEXP_EXTENDED_BITS))
 
 #if USE_FLONUMS
 #define sexp_integer_to_flonum(ctx, x) (sexp_make_flonum(ctx, sexp_unbox_integer(x)))

init.scm

@@ -529,3 +529,180 @@
     (if (and (pair? res) (eq? *values-tag* (car res)))
         (apply consumer (cdr res))
         (consumer res))))
+
+;; syntax-rules
+
+(define-syntax syntax-rules
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((lits (cadr expr))
+           (forms (cddr expr))
+           (count 0)
+           (_er-macro-transformer (rename 'er-macro-transformer))
+           (_lambda (rename 'lambda))      (_let (rename 'let))
+           (_begin (rename 'begin))        (_if (rename 'if))
+           (_and (rename 'and))            (_or (rename 'or))
+           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
+           (_car (rename 'car))            (_cdr (rename 'cdr))
+           (_cons (rename 'cons))          (_pair? (rename 'pair?))
+           (_null? (rename 'null?))        (_expr (rename 'expr))
+           (_rename (rename 'rename))      (_compare (rename 'compare))
+           (_quote (rename 'quote))        (_apply (rename 'apply))
+           (_append (rename 'append))      (_map (rename 'map))
+           (_vector? (rename 'vector?))    (_list? (rename 'list?))
+           (_lp (rename 'lp))              (_reverse (rename 'reverse))
+           (_vector->list (rename 'vector->list))
+           (_list->vector (rename 'list->vector)))
+       (define (next-v)
+         (set! count (+ count 1))
+         (rename (string->symbol (string-append "v." (number->string count)))))
+       (define (expand-pattern pat tmpl)
+         (let lp ((p (cdr pat))
+                  (x (list _cdr _expr))
+                  (dim 0)
+                  (vars '())
+                  (k (lambda (vars)
+                       (or (expand-template tmpl vars)
+                           (list _begin #f)))))
+           (let ((v (next-v)))
+             (list
+              _let (list (list v x))
+              (cond
+               ((identifier? p)
+                (if (any (lambda (l) (compare p l)) lits)
+                    (list _and (list _compare v (list _quote p)) (k vars))
+                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
+               ((ellipse? p)
+                (cond
+                 ((not (null? (cddr p)))
+                  (error "non-trailing ellipse"))
+                 ((identifier? (car p))
+                  (list _and (list _list? v)
+                        (list _let (list (list (car p) v))
+                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
+                 (else
+                  (let* ((w (next-v))
+                         (new-vars (all-vars (car p) (+ dim 1)))
+                         (ls-vars (map (lambda (x)
+                                         (rename
+                                          (string->symbol
+                                           (string-append
+                                            (symbol->string
+                                             (identifier->symbol (car x)))
+                                            "-ls"))))
+                                       new-vars))
+                         (once
+                          (lp (car p) (list _car w) (+ dim 1) '()
+                              (lambda (_)
+                                (cons
+                                 _lp
+                                 (cons
+                                  (list _cdr w)
+                                  (map (lambda (x l)
+                                         (list _cons (car x) l))
+                                       new-vars
+                                       ls-vars)))))))
+                    (list
+                     _let
+                     _lp (cons (list w v)
+                               (map (lambda (x) (list x '())) ls-vars))
+                     (list _if (list _null? w)
+                           (list _let (map (lambda (x l)
+                                             (list (car x) (list _reverse l)))
+                                           new-vars
+                                           ls-vars)
+                                 (k (append new-vars vars)))
+                           (list _and (list _pair? w) once)))))))
+               ((pair? p)
+                (list _and (list _pair? v)
+                      (lp (car p)
+                          (list _car v)
+                          dim
+                          vars
+                          (lambda (vars)
+                            (lp (cdr p) (list _cdr v) dim vars k)))))
+               ((vector? p)
+                (list _and
+                      (list _vector? v)
+                      (lp (vector->list p) (list _vector->list v) dim vars k)))
+               ((null? p) (list _and (list _null? v) (k vars)))
+               (else (list _and (list _equal? v p) (k vars))))))))
+       (define (ellipse? x)
+         (and (pair? x) (pair? (cdr x)) (compare '... (cadr x))))
+       (define (ellipse-depth x)
+         (if (ellipse? x)
+             (+ 1 (ellipse-depth (cdr x)))
+             0))
+       (define (ellipse-tail x)
+         (if (ellipse? x)
+             (ellipse-tail (cdr x))
+             (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)))
+                 ((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))
+                 (else vars))))
+       (define (free-vars x vars dim)
+         (let lp ((x x) (free '()))
+           (cond
+            ((identifier? x)
+             (if (and (not (memq x free))
+                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
+                            (else #f)))
+                 (cons x free)
+                 free))
+            ((pair? x) (lp (car x) (lp (cdr x) free)))
+            ((vector? x) (lp (vector->list x) free))
+            (else free))))
+       (define (expand-template tmpl vars)
+         (let lp ((t tmpl) (dim 0))
+           (cond
+            ((identifier? t)
+             (cond
+              ((assq t vars)
+               => (lambda (cell)
+                    (if (<= (cdr cell) dim)
+                        t
+                        (error "too few ...'s"))))
+              (else
+               (list _rename (list _quote t)))))
+            ((pair? t)
+             (if (ellipse? t)
+                 (let* ((depth (ellipse-depth t))
+                        (ell-dim (+ dim depth))
+                        (ell-vars (free-vars (car t) vars ell-dim)))
+                   (if (null? ell-vars)
+                       (error "too many ...'s")
+                       (let* ((once (lp (car t) ell-dim))
+                              (nest (if (and (null? (cdr ell-vars))
+                                             (identifier? once)
+                                             (eq? once (car vars)))
+                                        once ;; shortcut
+                                        (cons _map
+                                              (cons (list _lambda ell-vars once)
+                                                    ell-vars))))
+                              (many (do ((d depth (- d 1))
+                                         (many nest
+                                               (list _apply _append many)))
+                                        ((= d 1) many))))
+                         (if (null? (ellipse-tail t))
+                             many ;; shortcut
+                             (list _append many (lp (ellipse-tail t) dim))))))
+                 (list _cons (lp (car t) dim) (lp (cdr t) dim))))
+            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
+            ((null? t) (list _quote '()))
+            (else t))))
+       (list
+        _er-macro-transformer
+        (list _lambda (list _expr _rename _compare)
+              (cons
+               _or
+               (append
+                (map
+                 (lambda (clause) (expand-pattern (car clause) (cadr clause)))
+                 forms)
+                (list (list 'error "no expansion"))))))))))

sexp.c

@@ -53,6 +53,8 @@ sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag) {
   return res;
 }
 
+#if ! USE_BOEHM
+
 #define _DEF_TYPE(t,fb,flb,flo,fls,sb,so,sc,n) \
   {.tag=SEXP_TYPE, .value={.type={t,fb,flb,flo,fls,sb,so,sc,n}}}
 
@@ -90,11 +92,11 @@ static struct sexp_struct sexp_types[] = {
 
 #undef _DEF_TYPE
 
-#if ! USE_BOEHM
 #if ! USE_MALLOC
 #include "gc.c"
 #endif
-#endif
+
+#endif  /* ! USE_BOEHM */
 
 /***************************** exceptions *****************************/
 

syntax-rules.scm

@@ -1,182 +0,0 @@
-
-(define-syntax syntax-rules
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (let ((lits (cadr expr))
-           (forms (cddr expr))
-           (count 0)
-           (_er-macro-transformer (rename 'er-macro-transformer))
-           (_lambda (rename 'lambda))      (_let (rename 'let))
-           (_begin (rename 'begin))        (_if (rename 'if))
-           (_and (rename 'and))            (_or (rename 'or))
-           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
-           (_car (rename 'car))            (_cdr (rename 'cdr))
-           (_cons (rename 'cons))          (_pair? (rename 'pair?))
-           (_null? (rename 'null?))        (_expr (rename 'expr))
-           (_rename (rename 'rename))      (_compare (rename 'compare))
-           (_quote (rename 'quote))        (_apply (rename 'apply))
-           (_append (rename 'append))      (_map (rename 'map))
-           (_vector? (rename 'vector?))    (_list? (rename 'list?))
-           (_lp (rename 'lp))              (_reverse (rename 'reverse))
-           (_vector->list (rename 'vector->list))
-           (_list->vector (rename 'list->vector)))
-       (define (next-v)
-         (set! count (+ count 1))
-         (rename (string->symbol (string-append "v." (number->string count)))))
-       (define (expand-pattern pat tmpl)
-         (let lp ((p (cdr pat))
-                  (x (list _cdr _expr))
-                  (dim 0)
-                  (vars '())
-                  (k (lambda (vars)
-                       (or (expand-template tmpl vars)
-                           (list _begin #f)))))
-           (let ((v (next-v)))
-             (list
-              _let (list (list v x))
-              (cond
-               ((identifier? p)
-                (if (any (lambda (l) (compare p l)) lits)
-                    (list _and (list _compare v (list _quote p)) (k vars))
-                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
-               ((ellipse? p)
-                (cond
-                 ((not (null? (cddr p)))
-                  (error "non-trailing ellipse"))
-                 ((identifier? (car p))
-                  (list _and (list _list? v)
-                        (list _let (list (list (car p) v))
-                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
-                 (else
-                  (let* ((w (next-v))
-                         (new-vars (all-vars (car p) (+ dim 1)))
-                         (ls-vars (map (lambda (x)
-                                         (rename
-                                          (string->symbol
-                                           (string-append
-                                            (symbol->string
-                                             (identifier->symbol (car x)))
-                                            "-ls"))))
-                                       new-vars))
-                         (once
-                          (lp (car p) (list _car w) (+ dim 1) '()
-                              (lambda (_)
-                                (cons
-                                 _lp
-                                 (cons
-                                  (list _cdr w)
-                                  (map (lambda (x l)
-                                         (list _cons (car x) l))
-                                       new-vars
-                                       ls-vars)))))))
-                    (list
-                     _let
-                     _lp (cons (list w v)
-                               (map (lambda (x) (list x '())) ls-vars))
-                     (list _if (list _null? w)
-                           (list _let (map (lambda (x l)
-                                             (list (car x) (list _reverse l)))
-                                           new-vars
-                                           ls-vars)
-                                 (k (append new-vars vars)))
-                           (list _and (list _pair? w) once)))))))
-               ((pair? p)
-                (list _and (list _pair? v)
-                      (lp (car p)
-                          (list _car v)
-                          dim
-                          vars
-                          (lambda (vars)
-                            (lp (cdr p) (list _cdr v) dim vars k)))))
-               ((vector? p)
-                (list _and
-                      (list _vector? v)
-                      (lp (vector->list p) (list _vector->list v) dim vars k)))
-               ((null? p) (list _and (list _null? v) (k vars)))
-               (else (list _and (list _equal? v p) (k vars))))))))
-       (define (ellipse? x)
-         (and (pair? x) (pair? (cdr x)) (compare '... (cadr x))))
-       (define (ellipse-depth x)
-         (if (ellipse? x)
-             (+ 1 (ellipse-depth (cdr x)))
-             0))
-       (define (ellipse-tail x)
-         (if (ellipse? x)
-             (ellipse-tail (cdr x))
-             (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)))
-                 ((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))
-                 (else vars))))
-       (define (free-vars x vars dim)
-         (let lp ((x x) (free '()))
-           (cond
-            ((identifier? x)
-             (if (and (not (memq x free))
-                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
-                            (else #f)))
-                 (cons x free)
-                 free))
-            ((pair? x) (lp (car x) (lp (cdr x) free)))
-            ((vector? x) (lp (vector->list x) free))
-            (else free))))
-       (define (expand-template tmpl vars)
-         (let lp ((t tmpl) (dim 0))
-           (cond
-            ((identifier? t)
-             (cond
-              ((assq t vars)
-               => (lambda (cell)
-                    (if (<= (cdr cell) dim)
-                        t
-                        (error "too few ...'s"))))
-              (else
-               (list _rename (list _quote t)))))
-            ((pair? t)
-             (if (ellipse? t)
-                 (let* ((depth (ellipse-depth t))
-                        (ell-dim (+ dim depth))
-                        (ell-vars (free-vars (car t) vars ell-dim)))
-                   (if (null? ell-vars)
-                       (error "too many ...'s")
-                       (let* ((once (lp (car t) ell-dim))
-                              (nest (if (and (null? (cdr ell-vars))
-                                             (identifier? once)
-                                             (eq? once (car vars)))
-                                        once ;; shortcut
-                                        (cons _map
-                                              (cons (list _lambda ell-vars once)
-                                                    ell-vars))))
-                              (many (do ((d depth (- d 1))
-                                         (many nest
-                                               (list _apply _append many)))
-                                        ((= d 1) many))))
-                         (if (null? (ellipse-tail t))
-                             many ;; shortcut
-                             (list _append many (lp (ellipse-tail t) dim))))))
-                 (list _cons (lp (car t) dim) (lp (cdr t) dim))))
-            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
-            ((null? t) (list _quote '()))
-            (else t))))
-       (list
-        _er-macro-transformer
-        (list _lambda (list _expr _rename _compare)
-              (cons
-               _or
-               (append
-                (map
-                 (lambda (clause) (expand-pattern (car clause) (cadr clause)))
-                 forms)
-                (list (list 'error "no expansion"))))))))))
-
-;; Local Variables:
-;; eval: (put '_lambda 'scheme-indent-function 1)
-;; eval: (put '_let 'scheme-indent-function 'scheme-let-indent)
-;; eval: (put '_if 'scheme-indent-function 3)
-;; End:
-