* first library (ikarus interaction) is added.

* the library expander (syntax.ss) is added.

.bzrignore

@@ -5,3 +5,16 @@
 .vimview
 .DS_Store
 benchmarks/sys/*
+benchmarks/results.AWK-r6rs
+benchmarks/results.Chicken-r6rs
+benchmarks/results.GCC-r5rs
+benchmarks/results.GCC-r6rs
+benchmarks/results.Gambit-C-r6rs
+benchmarks/results.Ikarus-r6rs
+benchmarks/results.Java-r5rs
+benchmarks/results.Java-r6rs
+benchmarks/results.Larceny-r6rs
+benchmarks/results.MzScheme-r6rs
+benchmarks/results.Petite-Chez-Scheme-r5rs
+benchmarks/results.Petite-Chez-Scheme-r6rs
+benchmarks/results.Scheme48-r6rs

src/libcompile.ss

@@ -551,7 +551,8 @@
         [(funcall) #t]
         [(conditional) #f]
         [(bind lhs* rhs* body) (valid-mv-producer? body)]
-        [else (error 'valid-mv-producer? "unhandles ~s"
+        [else #f] ;; FIXME BUG
+        #;[else (error 'valid-mv-producer? "unhandles ~s"
                      (unparse x))]))
     (record-case rator
       [(clambda g cls*)
@@ -5223,6 +5224,12 @@
                ls*)])
         (car code*)))))
 
+
+(define compile-core-expr-to-port
+  (lambda (expr port)
+    (parameterize ([current-expand (lambda (x) x)])
+      (fasl-write (compile-expr expr) port))))
+
 (define compile-file
   (lambda (input-file output-file . rest)
     (let ([ip (open-input-file input-file)]
@@ -5248,6 +5255,8 @@
       (close-output-port op))))
 
 
+(primitive-set! 'compile-core-expr-to-port compile-core-expr-to-port)
+
 (primitive-set! 'compile-file compile-file)
 (primitive-set! 'alt-compile-file alt-compile-file)
 (primitive-set! 'assembler-output (make-parameter #f))

src/libtoplevel.ss

@@ -68,35 +68,38 @@
 
 
 ;;; Finally, we're ready to evaluate the files and enter the cafe.
-(let-values ([(files script args)
+(library (ikarus interaction)
-              (let f ([args (command-line-arguments)])
+  (export)
-                (cond
+  (import (scheme))
-                  [(null? args) (values '() #f '())]
+  (let-values ([(files script args)
-                  [(string=? (car args) "--")
+                (let f ([args (command-line-arguments)])
-                   (values '() #f (cdr args))]
+                  (cond
-                  [(string=? (car args) "--script")
+                    [(null? args) (values '() #f '())]
-                   (let ([d (cdr args)])
+                    [(string=? (car args) "--")
-                     (cond
+                     (values '() #f (cdr args))]
-                       [(null? d) 
+                    [(string=? (car args) "--script")
-                        (error #f "--script requires a script name")]
+                     (let ([d (cdr args)])
-                       [else
+                       (cond
-                        (values '() (car d) (cdr d))]))]
+                         [(null? d) 
-                  [else
+                          (error #f "--script requires a script name")]
-                   (let-values ([(f* script a*) (f (cdr args))])
+                         [else
-                     (values (cons (car args) f*) script a*))]))])
+                          (values '() (car d) (cdr d))]))]
-  (current-eval compile)
+                    [else
-  (cond
+                     (let-values ([(f* script a*) (f (cdr args))])
-    [script ; no greeting, no cafe
+                       (values (cons (car args) f*) script a*))]))])
-     (command-line-arguments (cons script args))
+    (current-eval compile)
-     (for-each load files)
+    (cond
-     (load script)
+      [script ; no greeting, no cafe
-     (exit 0)]
+       (command-line-arguments (cons script args))
-    [else
+       (for-each load files)
-     (printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
+       (load script)
-     (display "Copyright (c) 2006-2007 Abdulaziz Ghuloum\n\n")
+       (exit 0)]
-     (command-line-arguments args)
+      [else
-     (for-each load files)
+       (printf "Ikarus Scheme (Build ~a)\n" "NO TIME STRING")
-     (new-cafe)
+       ;(printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
-     (exit 0)]))
+       (display "Copyright (c) 2006-2007 Abdulaziz Ghuloum\n\n")
-
+       (command-line-arguments args)
+       (for-each load files)
+       (new-cafe)
+       (exit 0)])))
 

src/makefile.ss

@@ -26,7 +26,7 @@
     syntax quasisyntax unsyntax unsyntax-splicing datum
     let let* let-values cond case define-record or and when unless do
     include parameterize trace untrace trace-lambda trace-define
-    rec
+    rec library
     time))
 
 
@@ -153,6 +153,7 @@
     *current-output-port* *standard-input-port* *current-input-port*
     
     ;;; 
+    compile-core-expr-to-port
     compiler-giveup-tally
     ))
  
@@ -266,42 +267,6 @@
 (define (expand-file ifile)
   (map sc-expand (read-file ifile)))
 
-(define (compile-library ifile ofile which-compile)
-  (parameterize ([assembler-output #f] 
-                 [expand-mode 'bootstrap]
-                 [interaction-environment system-env])
-     (let ([proc 
-            (case which-compile
-              [(onepass) compile-file]
-              [(chaitin) alt-compile-file]
-              [else (error 'compile-library "unknown compile ~s"
-                           which-compile)])])
-      (printf "compiling ~a ... \n" ifile)
-      (proc ifile ofile 'replace))))
-
-
-
-#;(let ()
-  (define (compile-all who)
-    (for-each
-      (lambda (x)
-        (when (eq? who (caddr x))
-          (compile-library (car x) (cadr x) (cadddr x))))
-      scheme-library-files))
-  (define (time x) x)
-  (fork
-    (lambda (pid) 
-      (time (compile-all 'p1))
-      (unless (fxzero? (waitpid pid))
-        (exit -1)))
-    (lambda ()
-      (time (compile-all 'p0))
-      (exit))))
-
-(for-each 
-  (lambda (x)
-    (compile-library (car x) (cadr x) (cadddr x)))
-  scheme-library-files)
 
 (define (join s ls)
   (cond
@@ -317,11 +282,55 @@
             (display a str)
             (display s str)
             (f (car d) (cdr d))])))]))
-   
 
-(system
+(define (compile-all)
-  (format "cat ~a > ikarus.boot"
+  (define (compile-library ifile ofile which-compile)
-          (join " " (map cadr scheme-library-files))))
+    (parameterize ([assembler-output #f] 
+                   [expand-mode 'bootstrap]
+                   [interaction-environment system-env])
+       (let ([proc 
+              (case which-compile
+                [(onepass) compile-file]
+                [(chaitin) alt-compile-file]
+                [else (error 'compile-library "unknown compile ~s"
+                             which-compile)])])
+        (printf "compiling ~a ... \n" ifile)
+        (proc ifile ofile 'replace))))
+  
+  (for-each 
+    (lambda (x)
+      (compile-library (car x) (cadr x) (cadddr x)))
+    scheme-library-files)
+  (system
+    (format "cat ~a > ikarus.boot"
+            (join " " (map cadr scheme-library-files)))))
+
+(define (new-compile-all)
+  (define (slurp-file file)
+    (with-input-from-file file
+      (lambda ()
+        (let f ()
+          (let ([x (read)])
+            (if (eof-object? x)
+                '()
+                (cons x (f))))))))
+  (define (expand-library ifile)
+    (parameterize ([expand-mode 'bootstrap]
+                   [interaction-environment system-env])
+       (expand (cons 'begin (slurp-file ifile)))))
+  (define (expand-all ls)
+    (map (lambda (x) (expand-library (car x))) ls))
+  (printf "expanding ...\n")
+  (let ([core* (expand-all scheme-library-files)])
+  (printf "compiling ...\n")
+    (let ([p (open-output-file "ikarus.boot" 'replace)])
+      (for-each 
+        (lambda (x) (#%compile-core-expr-to-port x p))
+        core*)
+      (close-output-port p))))
+
+;(compile-all)
+(new-compile-all)
 
 (printf "Happy Happy Joy Joy\n")
 ;(#%compiler-giveup-tally)

src/psyntax-7.1.ss

@@ -684,6 +684,7 @@
 
 (define-syntax build-lexical-reference
   (syntax-rules ()
+    ((_ ae var) var)
     ((_ type ae var)
      var)))
 
@@ -1701,6 +1702,7 @@
                  (($import) (values '$import-form #f e w ae))
                  ((eval-when) (values 'eval-when-form #f e w ae))
                  ((meta) (values 'meta-form #f e w ae))
+                 ((library) (values 'library-form #f e w ae))
                  ((local-syntax)
                   (values 'local-syntax-form (binding-value b) e w ae))
                  (else (values 'call #f e w ae))))
@@ -1736,6 +1738,8 @@
                             meta-residualize! #f)))
               (cons first (dobody (cdr body)))))))))
 
+
+
 (define chi-top
   (lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
     (let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
@@ -1817,6 +1821,7 @@
                              (lambda ()
                                (build-global-definition ae valsym (chi rhs r r w #f)))))))))
              ))))
+        ((library-form) (chi-top-library e))
         (($module-form)
          (let ((ribcage (make-empty-ribcage)))
            (let-values (((orig id exports forms)
@@ -2045,6 +2050,10 @@
                                     (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
                             (loop bs))))))))))))
 
+
+(include "syntax.ss")
+
+
 (define id-set-diff
   (lambda (exports defs)
     (cond
@@ -3403,6 +3412,8 @@
 (global-extend 'alias 'alias '())
 (global-extend 'begin 'begin '())
 
+(global-extend 'library 'library '())
+
 (global-extend '$module-key '$module '())
 (global-extend '$import '$import '())
 

src/syntax.ss

@@ -0,0 +1,747 @@
+
+
+(define chi-top-library
+  (let ()
+    ;(define my-map
+    ;  (lambda (ctxt f ls . ls*)
+    ;    (cond
+    ;      [(and (list? ls) 
+    ;            (andmap list? ls*)
+    ;            (let ([n (length ls)])
+    ;              (andmap (lambda (ls) (= (length ls) n)) ls*)))
+    ;       (let loop ([ls ls] [ls* ls*])
+    ;         (cond
+    ;           [(null? ls) '()]
+    ;           [else
+    ;            (cons (apply f (car ls) (#%map car ls*))
+    ;                  (loop (cdr ls) (#%map cdr ls*)))]))]
+    ;      [else (error ctxt "invalid args ~s" (cons ls ls*))])))
+    ;(define-syntax map
+    ;  (syntax-rules ()
+    ;    [(_ f ls ls* ...)
+    ;     (my-map '(map f ls ls* ...) f ls ls* ...)]))
+
+    (define who 'chi-top-library)
+    (define-syntax assert
+      (syntax-rules ()
+        [(_ name pred* ...)
+         (unless (and pred* ...)
+           (error 'name "assertion ~s failed" '(pred* ...)))]))
+    (define top-mark* '(top))
+    (define top-marked?
+      (lambda (m*) (memq 'top m*)))
+    (define gen-lexical 
+      (lambda (sym)
+        (cond
+          [(symbol? sym) 
+           (gensym (symbol->string sym))]
+          [(stx? sym) (gen-lexical (id->sym sym))]
+          [else (error 'gen-lexical "invalid arg ~s" sym)])))
+    (define gen-label
+      (lambda (_) (gensym)))
+    (define make-rib
+      (lambda (sym* mark** label*)
+        (vector 'rib sym* mark** label*)))
+    (define id/label-rib
+      (lambda (id* label*)
+        (make-rib (map id->sym id*) (map stx-mark* id*) label*)))
+    (define make-empty-rib
+      (lambda ()
+        (make-rib '() '() '())))
+    (define extend-rib!
+      (lambda (rib id label)
+        (if (rib? rib)
+            (let ([sym (id->sym id)] [mark* (stx-mark* id)])
+              (vector-set! rib 1 (cons sym (vector-ref rib 1)))
+              (vector-set! rib 2 (cons mark* (vector-ref rib 2)))
+              (vector-set! rib 3 (cons label (vector-ref rib 3))))
+            (error 'extend-rib! "~s is not a rib" rib))))
+    (define rib?
+      (lambda (x) 
+        (and (vector? x)
+             (= (vector-length x) 4)
+             (eq? (vector-ref x 0) 'rib))))
+    (define rib-sym* 
+      (lambda (x)
+        (if (rib? x)
+            (vector-ref x 1)
+            (error 'rib-sym* "~s is not a rib" x))))
+    (define rib-mark** 
+      (lambda (x)
+        (if (rib? x)
+            (vector-ref x 2)
+            (error 'rib-mark** "~s is not a rib" x))))
+    (define rib-label* 
+      (lambda (x)
+        (if (rib? x)
+            (vector-ref x 3)
+            (error 'rib-label* "~s is not a rib" x))))
+    (define make-stx
+      (lambda (e m* s*)
+        (vector 'stx e m* s*)))
+    (define stx?
+      (lambda (x)
+        (and (vector? x) 
+             (= (vector-length x) 4)
+             (eq? (vector-ref x 0) 'stx))))
+    (define stx-expr 
+      (lambda (x)
+        (if (stx? x)
+            (vector-ref x 1)
+            (error 'stx-expr "~s is not a syntax object" x))))
+    (define stx-mark* 
+      (lambda (x)
+        (if (stx? x)
+            (vector-ref x 2)
+            (error 'stx-mark* "~s is not a syntax object" x))))
+    (define stx-subst* 
+      (lambda (x)
+        (if (stx? x)
+            (vector-ref x 3)
+            (error 'stx-subst* "~s is not a syntax object" x))))
+    (define join-wraps
+      (lambda (m1* s1* e)
+        (define cancel 
+          (lambda (ls1 ls2)
+            (let f ((x (car ls1)) (ls1 (cdr ls1)))
+              (if (null? ls1)
+                (cdr ls2)
+                (cons x (f (car ls1) (cdr ls1)))))))
+        (let ((m2* (stx-mark* e)) (s2* (stx-subst* e)))
+          (if (and (not (null? m1*))
+                   (not (null?  m2*))
+                   (eq? (car m2*) anti-mark))
+              ; cancel mark, anti-mark, and corresponding shifts
+              (values (cancel m1* m2*) (cancel s1* s2*))
+              (values (append m1* m2*) (append s1* s2*))))))
+    (define stx
+      (lambda (e m* s*)
+        (if (stx? e)
+            (let-values ([(m* s*) (join-wraps m* s* e)])
+              (make-stx (stx-expr e) m* s*))
+            (make-stx e m* s*))))
+    (define sym->free-id
+      (lambda (x)
+        (stx x top-mark* '())))
+    (define add-subst
+      (lambda (subst e)
+        (if subst
+            (stx e '() (list subst))
+            e)))
+    (define syntax-kind? 
+      (lambda (x p?)
+        (if (stx? x)
+            (syntax-kind? (stx-expr x) p?)
+            (p? x))))
+    (define syntax-pair?
+      (lambda (x) (syntax-kind? x pair?)))
+    (define syntax-null?
+      (lambda (x) (syntax-kind? x null?)))
+    (define syntax-list?
+      (lambda (x)
+        (or (syntax-null? x)
+            (and (syntax-pair? x) (syntax-list? (syntax-cdr x))))))
+    (define syntax-car
+      (lambda (x)
+        (if (stx? x)
+            (stx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x))
+            (if (pair? x)
+                (car x)
+                (error 'syntax-car "~s is not a pair" x)))))
+    (define syntax->list
+      (lambda (x)
+        (if (syntax-pair? x)
+            (cons (syntax-car x) (syntax->list (syntax-cdr x)))
+            (if (syntax-null? x)
+                '()
+                (error 'syntax->list "invalid ~s" x)))))
+    (define syntax-cdr
+      (lambda (x)
+        (if (stx? x)
+            (stx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x))
+            (if (pair? x)
+                (cdr x)
+                (error 'syntax-cdr "~s is not a pair" x))))) 
+    (define id?
+      (lambda (x) (syntax-kind? x symbol?)))
+    (define id->sym
+      (lambda (x)
+        (if (stx? x)
+            (id->sym (stx-expr x))
+            (if (symbol? x)
+                x
+                (error 'id->sym "~s is not an id" x)))))
+    (define same-marks?
+      (lambda (x y)
+        (or (eq? x y)
+            (and (pair? x) (pair? y)
+                 (eq? (car x) (car y))
+                 (same-marks? (cdr x) (cdr y))))))
+    (define bound-id=?
+      (lambda (x y)
+        (and (eq? (id->sym x) (id->sym y))
+             (same-marks? (stx-mark* x) (stx-mark* y)))))
+    (define free-id=?
+      (lambda (i j)
+        (let ((t0 (id->label i)) (t1 (id->label j)))
+          (if (or t0 t1)
+              (eq? t0 t1)
+              (eq? (id->sym i) (id->sym j))))))
+    (define valid-bound-ids?
+      (lambda (id*)
+        (and (andmap id? id*)
+             (distinct-bound-ids? id*))))
+    (define distinct-bound-ids?
+      (lambda (id*)
+        (or (null? id*)
+            (and (not (bound-id-member? (car id*) (cdr id*)))
+                 (distinct-bound-ids? (cdr id*))))))
+    (define bound-id-member? 
+      (lambda (id id*)
+        (and (pair? id*)
+             (or (bound-id=? id (car id*))
+                 (bound-id-member? id (cdr id*))))))
+    (define self-evaluating?
+      (lambda (x) 
+        (or (number? x) (string? x) (char? x) (boolean? x))))
+    (define strip
+      (lambda (x m*)
+        (if (top-marked? m*) 
+            x
+            (let f ([x x])
+              (cond
+                [(stx? x) (strip (stx-expr x) (stx-mark* x))]
+                [(pair? x)
+                 (let ([a (f (car x))] [d (f (cdr x))])
+                   (if (and (eq? a (car x)) (eq? d (cdr x)))
+                       x
+                       (cons a d)))]
+                [(vector? x)
+                 (let ([old (vector->list x)])
+                   (let ([new (map f old)])
+                     (if (andmap eq? old new) 
+                         x 
+                         (list->vector new))))]
+                [else x])))))
+    (define id->label
+      (lambda (id)
+        (assert id->label (id? id))
+        (let ([sym (id->sym id)])
+          (let search ([subst* (stx-subst* id)] [mark* (stx-mark* id)])
+            (cond
+              [(null? subst*) #f]
+              [(eq? (car subst*) 'shift) 
+               (search (cdr subst*) (cdr mark*))]
+              [else
+               (let ([rib (car subst*)])
+                 (let f ([sym* (rib-sym* rib)] 
+                         [mark** (rib-mark** rib)]
+                         [label* (rib-label* rib)])
+                   (cond
+                     [(null? sym*) (search (cdr subst*) mark*)]
+                     [(and (eq? (car sym*) sym)
+                           (same-marks? (car mark**) mark*))
+                      (car label*)]
+                     [else (f (cdr sym*) (cdr mark**) (cdr label*))])))])))))
+    (define label->binding
+      (lambda (x r)
+        (cond
+          [(not x) (cons 'unbound #f)]
+          [(assq x r) => cdr]
+          [else (cons 'displaced-lexical #f)])))
+    (define syntax-type
+      (lambda (e r)
+        (cond
+          [(id? e) 
+           (let ([id e])
+             (let* ([label (id->label id)]
+                    [b (label->binding label r)]
+                    [type (binding-type b)])
+               (unless label 
+                 (stx-error e "unbound identifier"))
+               (case type
+                 [(lexical core-prim)
+                  (values type (binding-value b) id)]
+                 [else (values 'other #f #f)])))]
+          [(syntax-pair? e)
+           (let ([id (syntax-car e)])
+             (if (id? id) 
+                 (let* ([label (id->label id)]
+                        [b (label->binding label r)]
+                        [type (binding-type b)])
+                   (case type
+                     [(define core-macro) 
+                      (values type (binding-value b) id)]
+                     [else 
+                      (values 'call #f #f)]))
+                 (values 'call #f #f)))]
+          [else (let ([d (strip e '())])
+                  (if (self-evaluating? d)
+                      (values 'constant d #f)
+                      (values 'other #f #f)))])))
+    (define parse-library 
+      (lambda (e)
+        (syntax-case e ()
+          [(_ (name name* ...)
+              (export exp* ...)
+              (import (scheme))
+              b* ...)
+           (and (eq? #'export 'export)
+                (eq? #'import 'import)
+                (eq? #'scheme 'scheme)
+                (symbol? #'name)
+                (andmap symbol? #'(name* ...))
+                (andmap symbol? #'(exp* ...)))
+           (values #'(name name* ...) #'(exp* ...) #'(b* ...))]
+          [_ (error who "malformed library ~s" e)])))
+    (define stx-error
+      (lambda (stx . args)
+        (error 'chi "invalid syntax ~s" (strip stx '()))))
+    (define-syntax syntax-match-test
+      (lambda (stx)
+        (define dots?
+          (lambda (x)
+            (and (identifier? x) 
+                 (free-identifier=? x #'(... ...)))))
+        (define f
+          (lambda (stx)
+            (syntax-case stx ()
+              [id (identifier? #'id) #'(lambda (x) #t)]
+              [(pat dots) (dots? #'dots)
+               (with-syntax ([p (f #'pat)])
+                 #'(lambda (x) 
+                     (and (syntax-list? x) 
+                          (andmap p (syntax->list x)))))]
+              [(pat dots . last) (dots? #'dots)
+               (with-syntax ([p (f #'pat)] [l (f #'last)])
+                 #'(lambda (x)
+                     (let loop ([x x])
+                       (cond
+                         [(syntax-pair? x) 
+                          (and (p (syntax-car x)) 
+                               (loop (syntax-cdr x)))]
+                         [else (l x)]))))]
+              [(a . d) 
+               (with-syntax ([pa (f #'a)] [pd (f #'d)])
+                 #'(lambda (x) 
+                     (and (syntax-pair? x)
+                          (pa (syntax-car x))
+                          (pd (syntax-cdr x)))))]
+              [datum 
+               #'(lambda (x) 
+                   (equal? (strip x '()) 'datum))])))
+        (syntax-case stx ()
+          [(_ x [pat code])
+           (with-syntax ([pat-code (f #'pat)])
+              #'(pat-code x))])))
+    (define-syntax syntax-match-conseq
+      (lambda (stx) 
+        (define dots?
+          (lambda (x)
+            (and (identifier? x) 
+                 (free-identifier=? x #'(... ...))))) 
+        (define f
+          (lambda (stx)
+            (syntax-case stx ()
+              [id (identifier? #'id) 
+               (values (list #'id) #'(lambda (x) x))]
+              [(pat dots) (dots? #'dots)
+               (let-values ([(vars extractor) (f #'pat)])
+                  (cond
+                    [(null? vars) 
+                     (values '() #'(lambda (x) (dont-call-me)))]
+                    [else
+                     (values vars
+                       (with-syntax ([(vars ...) vars]
+                                     [ext extractor]
+                                     [(t* ...) (generate-temporaries vars)])
+                         #'(lambda (x) 
+                             (let f ([x x] [vars '()] ...)
+                               (cond
+                                 [(syntax-null? x) 
+                                  (values (reverse vars) ...)]
+                                 [else
+                                  (let-values ([(t* ...) (ext (syntax-car x))])
+                                    (f (syntax-cdr x) 
+                                       (cons t* vars)
+                                       ...))])))))]))]
+              [(pat dots . last) (dots? #'dots)
+               (let-values ([(pvars pext) (f #'pat)])
+                 (let-values ([(lvars lext) (f #'d)])
+                   (cond
+                     [(and (null? pvars) (null? lvars)) 
+                      (values '() #'(lambda (x) (dont-call-me)))]
+                     [(null? lvars)
+                      (values pvars
+                        (with-syntax ([(pvars ...) pvars]
+                                      [(t* ...) (generate-temporaries pvars)]
+                                      [pext pext])
+                          #'(lambda (x)
+                              (let loop ([x x] [pvars '()] ...)
+                                (cond
+                                  [(syntax-pair? x)
+                                   (let-values ([(t* ...) (pext (syntax-car x))])
+                                     (loop (syntax-cdr x) 
+                                           (cons t* pvars) ...))]
+                                  [else
+                                   (values (reverse pvars) ...)])))))]
+                     [(null? pvars)
+                      (values lvars
+                        (with-syntax ([lext lext])
+                          #'(let loop ([x x])
+                              (cond
+                                [(syntax-pair? x) (loop (syntax-cdr x))]
+                                [else (lext x)]))))]
+                     [else
+                      (values (append pvars lvars)
+                        (with-syntax ([(pvars ...) pvars]
+                                      [(t* ...) (generate-temporaries pvars)]
+                                      [(lvars ...) lvars]
+                                      [lext lext]
+                                      [pext pext])
+                          #'(lambda (x)
+                              (let loop ([x x] [pvars '()] ...)
+                                (cond
+                                  [(syntax-pair? x)
+                                   (let-values ([(t* ...) (pext (syntax-car x))])
+                                     (loop (syntax-cdr x) 
+                                           (cons t* pvars) ...))]
+                                  [else
+                                   (let-values ([(lvars ...) (lext x)])
+                                     (values (reverse pvars) ...
+                                             lvars ...))])))))])))]
+              [(a . d) 
+               (let-values ([(avars aextractor) (f #'a)])
+                 (let-values ([(dvars dextractor) (f #'d)])
+                   (cond
+                     [(and (null? avars) (null? dvars))
+                      (values '() #'(lambda (x) (dot-call-me)))]
+                     [(null? avars) 
+                      (values dvars
+                        (with-syntax ([d dextractor])
+                          #'(lambda (x) (d (syntax-cdr x)))))]
+                     [(null? dvars) 
+                      (values avars
+                        (with-syntax ([a aextractor])
+                          #'(lambda (x) (a (syntax-car x)))))]
+                     [else
+                      (values (append avars dvars)
+                        (with-syntax ([(avars ...) avars]
+                                      [(dvars ...) dvars]
+                                      [a aextractor]
+                                      [d dextractor])
+                          #'(lambda (x)
+                              (let-values ([(avars ...) (a (syntax-car x))])
+                                (let-values ([(dvars ...) (d (syntax-cdr x))])
+                                  (values avars ... dvars ...))))))])))]
+              [datum 
+               (values '() #'(lambda (x) (dot-call-me)))])))
+        (syntax-case stx ()
+          [(_ x [pat code])
+           (let-values ([(vars extractor) 
+                         (f #'pat)])
+             (with-syntax ([e extractor] [(vs ...) vars])
+               (case (length vars)
+                 [(0) #'code]
+                 [(1) #'(let ([vs ... (e x)]) code)]
+                 [else #'(let-values ([(vs ...) (e x)]) code)])))])))
+    (define-syntax syntax-match
+      (lambda (x)
+        (syntax-case x ()
+          [(_ expr) #'(stx-error expr)]
+          [(_ expr cls cls* ...) 
+           #'(let ([t expr]) 
+               (if (syntax-match-test t cls)
+                   (syntax-match-conseq t cls)
+                   (syntax-match t cls* ...)))])))
+    (define parse-define
+      (lambda (x)
+        (syntax-match x
+          [(_ (id . fmls) b b* ...) 
+           (if (id? id) 
+               (values id
+                (cons 'defun (cons fmls (cons b b*))))
+               (stx-error x))]
+          [(_ id val)
+           (if (id? id) 
+               (values id (cons 'expr val))
+               (stx-error x))])))
+    (define scheme-env
+      '([define     define-label     (define)]
+        [quote      quote-label      (core-macro . quote)]
+        [let-values let-values-label (core-macro . let-values)]
+        [let        let-label        (core-macro . let)]
+        [cond       cond-label       (core-macro . cond)]
+        [cons       cons-label       (core-prim . cons)]
+        [values     values-label     (core-prim . values)]
+        [car        car-label        (core-prim . car)]
+        [cdr        cdr-label        (core-prim . cdr)]
+        [null?      null?-label      (core-prim . null?)]
+        [error      error-label      (core-prim . error)]
+        [exit       exit-label       (core-prim . exit)]
+        [new-cafe   new-cafe-label   (core-prim . new-cafe)]
+        [load       load-label       (core-prim . load)]
+        [for-each   for-each-label   (core-prim . for-each)]
+        [display    display-label    (core-prim . display)]
+        [current-eval current-eval-label (core-prim . current-eval)]
+        [compile    compile-label    (core-prim . compile)]
+        [printf     printf-label     (core-prim . printf)]
+        [string=?   string=?-label   (core-prim . string=?)]
+        [command-line-arguments command-line-arguments-label (core-prim .  command-line-arguments)]
+        ))
+    (define make-scheme-rib
+      (lambda ()
+        (let ([rib (make-empty-rib)])
+          (for-each 
+            (lambda (x)
+              (let ([name (car x)] [label (cadr x)])
+                (extend-rib! rib (stx name top-mark* '()) label)))
+            scheme-env)
+          rib)))
+    (define make-scheme-env
+      (lambda ()
+        (map 
+          (lambda (x) 
+             (let ([name (car x)] [label (cadr x)] [binding (caddr x)])
+               (cons label binding)))
+           scheme-env)))
+    ;;; macros
+    (define add-lexicals
+      (lambda (lab* lex* r)
+        (append (map (lambda (lab lex)
+                       (cons lab (cons 'lexical lex)))
+                     lab* lex*)
+                r)))
+    (define let-values-transformer
+      (lambda (e r mr) 
+        (syntax-match e
+          [(_ ([(fml** ...) rhs*] ...) b b* ...)
+           (let ([rhs* (chi-expr* rhs* r mr)])
+             (let ([lex** (map (lambda (ls) (map gen-lexical ls)) fml**)]
+                   [lab** (map (lambda (ls) (map gen-label ls)) fml**)])
+               (let ([fml* (apply append fml**)]
+                     [lab* (apply append lab**)]
+                     [lex* (apply append lex**)])
+                 (let f ([lex** lex**] [rhs* rhs*])
+                    (cond
+                      [(null? lex**) 
+                       (chi-internal 
+                         (add-subst 
+                           (id/label-rib fml* lab*)
+                           (cons b b*))
+                         (add-lexicals lab* lex* r)
+                         mr)]
+                      [else
+                       (build-application no-source 
+                         (build-primref no-source 'call-with-values)
+                         (list 
+                           (build-lambda no-source '() (car rhs*))
+                           (build-lambda no-source (car lex**) 
+                             (f (cdr lex**) (cdr rhs*)))))])))))])))
+    (define let-transformer
+      (lambda (e r mr)
+        (syntax-match e
+          [(_ ([lhs* rhs*] ...) b b* ...) 
+           (if (not (valid-bound-ids? lhs*))
+               (stx-error e)
+               (let ([rhs* (chi-expr* rhs* r mr)]
+                     [lex* (map gen-lexical lhs*)]
+                     [lab* (map gen-label lhs*)])
+                 (let ([body (chi-internal 
+                               (add-subst 
+                                 (id/label-rib lhs* lab*)
+                                 (cons b b*))
+                               (add-lexicals lab* lex* r)
+                               mr)])
+                   (build-application no-source 
+                     (build-lambda no-source lex* body)
+                     rhs*))))]
+          [(_ loop ([lhs* rhs*] ...) b b* ...)
+           (if (and (id? loop) (valid-bound-ids? lhs*))
+               (let ([rhs* (chi-expr* rhs* r mr)]
+                     [lex* (map gen-lexical lhs*)]
+                     [lab* (map gen-label lhs*)]
+                     [looplex (gen-lexical loop)]
+                     [looplab (gen-label loop)])
+                 (let ([b* (add-subst (id/label-rib (list loop) (list looplab))
+                             (add-subst (id/label-rib lhs* lab*)
+                               (cons b b*)))]
+                       [r (add-lexicals 
+                            (cons looplab lab*)
+                            (cons looplex lex*)
+                            r)])
+                   (let ([body (chi-internal b* r mr)])
+                     (build-letrec no-source 
+                        (list looplex)
+                        (list (build-lambda no-source lex* body))
+                        (build-application no-source 
+                          looplex rhs*)))))
+               (stx-error e))])))
+    (define cond-transformer
+      (lambda (expr r mr)
+        (define handle-arrow 
+          (lambda (e v altern)
+            (let ([t (gen-lexical 't)])
+              (build-let no-source 
+                 (list t) (list (chi-expr e r mr))
+                 (build-conditional no-source
+                   (build-lexical-reference no-source t)
+                   (build-application no-source
+                     (chi-expr v r mr) 
+                     (list (build-lexical-reference no-source t)))
+                   altern)))))
+        (define chi-last
+          (lambda (e)
+            (syntax-match e
+              [(e0 e1 e2* ...)
+               (if (free-id=? e0 (sym->free-id 'else))
+                   (build-sequence no-source 
+                     (chi-expr* (cons e1 e2*) r mr))
+                   (chi-one e (chi-void)))]
+              [_ (chi-one e (chi-void))])))
+        (define chi-one 
+          (lambda (e rest)
+            (define chi-test
+              (lambda (e rest)
+                (syntax-match e
+                  [(e0 e1 e2 ...)
+                   (build-conditional no-source 
+                     (chi-expr e0 r mr)
+                     (build-sequence no-source
+                        (chi-expr* (cons e1 e2) r mr))
+                     rest)]
+                  [_ (stx-error expr)])))
+            (syntax-match e
+              [(e0 e1 e2) 
+               (if (free-id=? e1 (sym->free-id '=>))
+                   (handle-arrow e0 e2 rest)
+                   (chi-test e rest))]
+              [_ (chi-test e rest)])))
+        (syntax-match expr
+          [(_) (chi-void)]
+          [(_ e e* ...)
+           (let f ([e e] [e* e*])
+             (cond
+               [(null? e*) (chi-last e)]
+               [else (chi-one e (f (car e*) (cdr e*)))]))])))
+    (define quote-transformer
+      (lambda (e r mr)
+        (syntax-match e
+          [(_ datum) (build-data no-source (strip datum '()))])))
+    (define core-macro-transformer
+      (lambda (name)
+        (case name
+          [(quote)      quote-transformer]
+          [(let-values) let-values-transformer]
+          [(let)        let-transformer]
+          [(cond)       cond-transformer]
+          [else (error 'macro-transformer "cannot find ~s" name)])))
+    ;;; chi procedures
+    (define chi-expr* 
+      (lambda (e* r mr)
+        (map (lambda (e) (chi-expr e r mr)) e*)))
+    (define chi-expr
+      (lambda (e r mr)
+        (let-values ([(type value kwd) (syntax-type e r)])
+          (case type
+            [(core-macro)
+             (let ([transformer (core-macro-transformer value)])
+               (transformer e r mr))]
+            [(core-prim) 
+             (let ([name value])
+               (build-primref no-source name))]
+            [(call) 
+             (syntax-match e 
+               [(rator rands ...) 
+                (build-application no-source 
+                  (chi-expr rator r mr)
+                  (chi-expr* rands r mr))])]
+            [(lexical)
+             (let ([lex value])
+               (build-lexical-reference no-source lex))]
+            [(constant)
+             (let ([datum value])
+               (build-data no-source datum))]
+            [else (error 'chi-expr "invalid type ~s for ~s" type
+                         (strip e '())) (stx-error e)]))))
+    (define chi-internal
+      (lambda (e* r mr)
+        (define return
+          (lambda (init* r mr lhs* lex* rhs*)
+            (unless (valid-bound-ids? lhs*) 
+              (error 'chi-internal "multiple definitions"))
+            (let ([rhs* (chi-expr* rhs* r mr)]
+                  [init* (chi-expr* init* r mr)])
+              (build-letrec no-source 
+                 (reverse lex*) (reverse rhs*) 
+                 (build-sequence no-source init*)))))
+        (let* ([rib (make-empty-rib)]
+               [e* (map (lambda (x) (add-subst rib x)) 
+                        (syntax->list e*))])
+          (let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
+            (cond
+              [(null? e*) (error 'chi-internal "empty body")]
+              [else
+               (let ([e (car e*)])
+                 (let-values ([(type value kwd) (syntax-type e r)])
+                   (let ([kwd* (cons kwd kwd*)])
+                     (case type
+                       [(define) 
+                        (let-values ([(id rhs) (parse-define e)])
+                          (when (bound-id-member? id kwd*) 
+                            (stx-error id "undefined identifier"))
+                          (let ([lex (gen-lexical id)]
+                                [label   (gen-label)])
+                            (extend-rib! rib id label)
+                            (f (cdr e*)
+                               (cons (cons label (cons 'lexical lex)) r)
+                               mr 
+                               (cons id lhs*)
+                               (cons lex lex*)
+                               (cons rhs rhs*)
+                               kwd*)))]
+                       [else 
+                        (return e* r mr lhs* lex* rhs*)]))))])))))
+    (define chi-library-internal 
+      (lambda (e* r rib)
+        (define return
+          (lambda (init* r mr lhs* rhs*)
+            (values init* r mr (reverse lhs*) (reverse rhs*))))
+        (let f ([e* e*] [r r] [mr r] [lhs* '()] [rhs* '()] [kwd* '()])
+          (cond
+            [(null? e*) (return e* r mr lhs* rhs*)]
+            [else
+             (let ([e (car e*)])
+               (let-values ([(type value kwd) (syntax-type e r)])
+                 (let ([kwd* (cons kwd kwd*)])
+                   (case type
+                     [(define) 
+                      (let-values ([(id rhs) (parse-define e)])
+                        (when (bound-id-member? id kwd*) 
+                          (stx-error id "undefined identifier"))
+                        (let ([lexical (gen-lexical (id->sym id))]
+                              [label   (gen-label)])
+                          (extend-rib! rib id label)
+                          (f (cdr e*) r mr (cons id lhs*) (cons rhs rhs*)
+                             kwd*)))]
+                     [else 
+                      (return e* r mr lhs* rhs*)]))))]))))
+    (define chi-top-library
+      (lambda (e)
+        (let-values ([(name exp* b*) (parse-library e)])
+          (let ([rib (make-scheme-rib)]
+                [r (make-scheme-env)])
+            (let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)])
+              (let-values ([(init* r mr lhs* rhs*)
+                            (chi-library-internal b* r rib)])
+                (unless (null? lhs*)
+                  (error who "cannot handle definitions yet"))
+                (if (null? init*) 
+                    (chi-void)
+                    (build-sequence no-source 
+                      (chi-expr* init* r mr)))))))))
+    (lambda (x) 
+      (let ([x (chi-top-library x)])
+        (pretty-print x)
+        x))
+    ))