(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-syntax build-let
      (syntax-rules ()
        [(_ ae lhs* rhs* body)
         (build-application ae
           (build-lambda ae lhs* body)
           rhs*)]))
    (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 datum->stx
      (lambda (id datum)
        (make-stx datum (stx-mark* id) (stx-subst* id))))
    (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 gen-mark
      (lambda () (string #\m)))
    (define add-mark
      (lambda (m e)
        (stx e (list m) '(shift))))
    (define anti-mark #f)
    (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 define-syntax core-macro begin macro
                        module set!)
                      (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-match e 
          [(_ (name name* ...)
              (export exp* ...)
              (import (scheme))
              b* ...)
           (if (and (eq? export 'export)
                    (eq? import 'import)
                    (eq? scheme 'scheme)
                    (symbol? name)
                    (andmap symbol? name*)
                    (andmap symbol? exp*))
               (values (cons name name*) exp* b*)
               (error who "malformed library ~s" e))]
          [_ (error who "malformed library ~s" e)])))
    (define-syntax stx-error 
      (syntax-rules ()
        [(_ stx) (error 'chi "invalid syntax ~s" (strip stx '()))]
        [(_ stx msg) (error 'chi "~a: ~s" msg (strip stx '()))]))
    ;(define stx-error
    ;  (lambda (stx . args)
    ;    (error 'chi "invalid syntax ~s" (strip stx '()))))
    (define sanitize-binding
      (lambda (x)
        (cond
          [(procedure? x) (cons 'macro x)]
          [(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
           x]
          [(and (pair? x) (eq? (car x) '$rtd)) x]
          [else (error 'expand "invalid transformer ~s" x)])))
    (define make-eval-transformer
      (lambda (x)
        (sanitize-binding (local-eval-hook x)))) 
    (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 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 #'last)])
                   (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 code* ...])
           (let-values ([(vars extractor) 
                         (f #'pat)])
             (with-syntax ([e extractor] [(vs ...) vars])
               (case (length vars)
                 [(0) #'(begin code code* ...)]
                 [(1) #'(let ([vs ... (e x)]) code code* ...)]
                 [else #'(let-values ([(vs ...) (e x)]) code 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 parse-define-syntax
      (lambda (x)
        (syntax-match x
          [(_ id val) 
           (if (id? id) 
               (values id val)
               (stx-error x))])))
    (define scheme-env ; the-env
      '([define     define-label     (define)]
        [define-syntax define-syntax-label (define-syntax)]
        [module     module-label     (module)]
        [begin      begin-label      (begin)]
        [set!       set!-label       (set!)]
        [define-record define-record-label (macro .  define-record)]
        [case          case-label          (core-macro .  case)]
        [foreign-call foreign-call-label (core-macro .  foreign-call)]
        [quote      quote-label      (core-macro . quote)]
        [lambda     lambda-label     (core-macro . lambda)]
        [case-lambda case-lambda-label (core-macro . case-lambda)]
        [let-values let-values-label (core-macro . let-values)]
        [let        let-label        (core-macro . let)]
        [letrec     letrec-label     (core-macro . letrec)]
        [let*       let*-label       (core-macro . let*)]
        [cond       cond-label       (core-macro . cond)]
        [if         if-label         (core-macro . if)]
        [when       when-label       (core-macro . when)]
        [unless     unless-label     (core-macro . unless)]
        [and        and-label        (core-macro . and)]
        [or         or-label         (core-macro . or)]
        [parameterize parameterize-label (core-macro . parameterize)]
        ;;; prims
        [void         void-label        (core-prim . void)]
        [not          not-label         (core-prim . not)]
        [boolean?     boolean-label     (core-prim . boolean?)]
        [null?        null?-label       (core-prim . null?)]
        [procedure?   procedure?-label  (core-prim . procedure?)]
        [eof-object?  eof-object?-label (core-prim . eof-object?)]
        [eof-object   eof-object-label  (core-prim . eof-object)]
        ;;; comparison
        [eq?        eq?-label        (core-prim . eq?)]
        [eqv?       eqv?-label       (core-prim . eqv?)]
        [equal?     equal?-label     (core-prim . equal?)]
        ;;; pairs/lists
        [cons       cons-label       (core-prim . cons)]
        [pair?      pair?-label      (core-prim . pair?)]
        [car        car-label        (core-prim . car)]
        [cdr        cdr-label        (core-prim . cdr)]
        [set-car!   set-car!-label   (core-prim . set-car!)]
        [set-cdr!   set-cdr!-label   (core-prim . set-cdr!)]
        [caar       caar-label       (core-prim . caar)]
        [cdar       cdar-label       (core-prim . cdar)]
        [cadr       cadr-label       (core-prim . cadr)]
        [cddr       cddr-label       (core-prim . cddr)]
        [list       list-label       (core-prim . list)]
        [list-ref       list-ref-label       (core-prim . list-ref)]
        [make-list make-list-label (core-prim . make-list)]
        [list*       list*-label       (core-prim . list*)]
        [list?      list?-label      (core-prim . list?)]
        [append     append-label     (core-prim . append)]
        [last-pair     last-pair-label     (core-prim . last-pair)]
        [reverse     reverse-label     (core-prim . reverse)]
        [length     length-label     (core-prim . length)]
        [assq       assq-label       (core-prim . assq)]
        [assv       assv-label       (core-prim . assv)]
        [assoc      assoc-label      (core-prim . assoc)]
        [memq       memq-label       (core-prim . memq)]
        [memv       memv-label       (core-prim . memv)]
        [member     member-label     (core-prim . member)]
        [$car       $car-label       (core-prim . $car)]
        [$cdr       $cdr-label       (core-prim . $cdr)]
        [$set-car!       $set-car!-label       (core-prim . $set-car!)]
        [$set-cdr!       $set-cdr!-label       (core-prim . $set-cdr!)]
        [$memq       $memq-label       (core-prim . $memq)]
        [$memv       $memv-label       (core-prim . $memv)]
        ;;; weak conses
        [bwp-object?  bwp-object?-label (core-prim . bwp-object?)]
        [weak-cons       weak-cons-label       (core-prim . weak-cons)]
        [weak-pair?       weak-pair?-label       (core-prim . weak-pair?)]
        ;;; chars
        [char?     char?-label     (core-prim . char?)]
        [char=?     char=?-label     (core-prim . char=?)]
        [char<?     char<?-label     (core-prim . char<?)]
        [char>?     char>?-label     (core-prim . char>?)]
        [char<=?     char<=?-label     (core-prim . char<=?)]
        [char>=?     char>=?-label     (core-prim . char>=?)]
        [integer->char integer->char-label (core-prim . integer->char)]
        [char->integer char->integer-label (core-prim . char->integer)]
        [char-whitespace? char-whitespace?-label (core-prim . char-whitespace?)]
        [$char?     $char?-label     (core-prim . $char?)]
        [$char=    $char=-label    (core-prim . $char=)]
        [$char<    $char<-label    (core-prim . $char<)]
        [$char>    $char>-label    (core-prim . $char>)]
        [$char<=    $char<=-label    (core-prim . $char<=)]
        [$char>=    $char>=-label    (core-prim . $char>=)]
        [$char->fixnum $char->fixnum-label (core-prim . $char->fixnum)]
        [$fixnum->char $fixnum->char-label (core-prim . $fixnum->char)]
        ;;; strings
        [string?    string?-label    (core-prim . string?)]
        [string    string-label    (core-prim . string)]
        [make-string make-string-label (core-prim . make-string)]
        [string-ref string-ref-label (core-prim . string-ref)]
        [string-set! string-set!-label (core-prim . string-set!)]
        [string-length string-length-label (core-prim . string-length)]
        [string=?   string=?-label   (core-prim . string=?)]
        [substring  substring-label  (core-prim . substring)]
        [string-append string-append-label (core-prim . string-append)]
        [string->list string->list-label (core-prim . string->list)]
        [list->string list->string-label (core-prim . list->string)]
        [uuid    uuid-label    (core-prim . uuid)]
        [date-string    date-string-label    (core-prim . date-string)]
        [$make-string $make-string-label (core-prim . $make-string)]
        [$string-ref $string-ref-label (core-prim . $string-ref)]
        [$string-set! $string-set!-label (core-prim . $string-set!)]
        [$string-length $string-length-label (core-prim . $string-length)]
        ;;; vectors
        [vector      vector-label      (core-prim . vector)]
        [make-vector make-vector-label (core-prim . make-vector)]
        [vector-ref  vector-ref-label  (core-prim . vector-ref)]
        [vector-set! vector-set!-label (core-prim . vector-set!)]
        [vector?     vector?-label     (core-prim . vector?)]
        [vector-length vector-length-label (core-prim . vector-length)]
        [list->vector list->vector-label (core-prim . list->vector)]
        [vector->list vector->list-label (core-prim . vector->list)]
        [$make-vector $make-vector-label (core-prim . $make-vector)]
        [$vector-length $vector-length-label (core-prim . $vector-length)]
        [$vector-ref $vector-ref-label (core-prim . $vector-ref)]
        [$vector-set! $vector-set!-label (core-prim . $vector-set!)]
        ;;; iterators
        [for-each   for-each-label   (core-prim . for-each)]
        [map        map-label        (core-prim . map)]
        [andmap     andmap-label     (core-prim . andmap)]
        [ormap      ormap-label      (core-prim . ormap)]
        ;;; fixnums
        [fixnum?    fixnum-label     (core-prim . fixnum?)]
        [fx<        fx<-label        (core-prim . fx<)]
        [fx<=       fx<=-label       (core-prim . fx<=)]
        [fx>        fx>-label        (core-prim . fx>)]
        [fx>=       fx>=-label       (core-prim . fx>=)]
        [fx=        fx=-label        (core-prim . fx=)]
        [fx-        fx--label        (core-prim . fx-)]
        [fx+        fx+-label        (core-prim . fx+)]
        [fx*        fx*-label        (core-prim . fx*)]
        [fxzero?    fxzero?-label    (core-prim . fxzero?)]
        [fxadd1     fxadd1-label     (core-prim . fxadd1)]
        [fxsub1     fxsub1-label     (core-prim . fxsub1)]
        [fxquotient fxquotient-label (core-prim . fxquotient)]
        [fxremainder fxremainder-label (core-prim . fxremainder)]
        [fxmodulo fxmodulo-label (core-prim . fxmodulo)]
        [fxsll       fxsll-label       (core-prim . fxsll)]
        [fxsra       fxsra-label       (core-prim . fxsra)]
        [fxlogand    fxlogand-label    (core-prim . fxlogand)]
        [fxlogxor    fxlogxor-label    (core-prim . fxlogxor)]
        [fxlogor    fxlogor-label    (core-prim . fxlogor)]
        [fxlognot    fxlognot-label    (core-prim . fxlognot)]
        [fixnum->string fixnum->string-label (core-prim . fixnum->string)]
        [$fxzero?    $fxzero?-label    (core-prim . $fxzero?)]
        [$fxadd1        $fxadd1-label        (core-prim . $fxadd1)]
        [$fxsub1        $fxsub1-label        (core-prim . $fxsub1)]
        [$fx>=       $fx>=-label       (core-prim . $fx>=)]
        [$fx<=       $fx<=-label       (core-prim . $fx<=)]
        [$fx>       $fx>-label       (core-prim . $fx>)]
        [$fx<       $fx<-label       (core-prim . $fx<)]
        [$fx=        $fx=-label        (core-prim . $fx=)]
        [$fxsll        $fxsll-label        (core-prim . $fxsll)]
        [$fxsra        $fxsra-label        (core-prim . $fxsra)]
        [$fxquotient $fxquotient-label (core-prim . $fxquotient)]
        [$fxmodulo $fxmodulo-label (core-prim . $fxmodulo)]
        [$fxlogxor        $fxlogxor-label        (core-prim . $fxlogxor)]
        [$fxlogor        $fxlogor-label        (core-prim . $fxlogor)]
        [$fxlognot        $fxlognot-label        (core-prim . $fxlognot)]
        [$fxlogand        $fxlogand-label        (core-prim . $fxlogand)]
        [$fx+        $fx+-label        (core-prim . $fx+)]
        [$fx*        $fx*-label        (core-prim . $fx*)]
        [$fx-        $fx--label        (core-prim . $fx-)]
        ;;; flonum
        [string->flonum string->flonum-label (core-prim . string->flonum)]
        ;;; generic arithmetic
        [-          minus-label      (core-prim . -)]
        [=          =-label          (core-prim . =)]
        [<          <-label          (core-prim . <)]
        [>          >-label          (core-prim . >)]
        [<=          <=-label          (core-prim . <=)]
        [>=          >=-label          (core-prim . >=)]
        [*          *-label          (core-prim . *)]
        [+          plus-label       (core-prim . +)]
        [number?   number?-label   (core-prim . number?)]
        [quotient   quotient-label   (core-prim . quotient)]
        [number->string   number->string-label   (core-prim . number->string)]
        [string->number   string->number-label   (core-prim . string->number)]
        ;;; symbols/gensyms
        [symbol?    symbol?-label    (core-prim . symbol?)]
        [gensym?    gensym?-label    (core-prim . gensym?)]
        [gensym     gensym-label     (core-prim . gensym)]
        [getprop    getprop-label    (core-prim . getprop)]
        [putprop    putprop-label    (core-prim . putprop)]
        [remprop    remprop-label    (core-prim . remprop)]
        [property-list    property-list-label    (core-prim . property-list)]
        [string->symbol string->symbol-label (core-prim . string->symbol)]
        [symbol->string symbol->string-label (core-prim . symbol->string)]
        [gensym->unique-string gensym->unique-string-label (core-prim . gensym->unique-string)]
        [$make-symbol     $make-symbol-label     (core-prim . $make-symbol)]
        [$symbol-unique-string $symbol-unique-string-label (core-prim . $symbol-unique-string)]
        [$symbol-value $symbol-value-label (core-prim . $symbol-value)]
        [$symbol-string $symbol-string-label (core-prim . $symbol-string)]
        [$symbol-plist $symbol-plist-label (core-prim . $symbol-plist)]
        [$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)]
        [$set-symbol-string! $set-symbol-string!-label (core-prim . $set-symbol-string!)]
        [$set-symbol-unique-string! $set-symbol-unique-string!-label (core-prim . $set-symbol-unique-string!)]
        [$set-symbol-plist! $set-symbol-plist!-label (core-prim . $set-symbol-plist!)]
        ;;; top-level
        [top-level-bound?     top-level-bound-label      (core-prim . top-level-bound?)]
        [top-level-value      top-level-value-label      (core-prim .  top-level-value)]
        [set-top-level-value! set-top-level-value!-label (core-prim .  set-top-level-value!)]
        ;;; IO/ports
        [output-port?        output-port?-label        (core-prim .  output-port?)]
        [input-port?        input-port?-label        (core-prim .  input-port?)]
        [input-port-name        input-port-name-label        (core-prim .  input-port-name)]
        [output-port-name        output-port-name-label        (core-prim .  output-port-name)]
        [open-input-file  open-input-file-label  (core-prim .  open-input-file)]
        [open-output-file  open-output-file-label  (core-prim .  open-output-file)]
        [open-output-string  open-output-string-label  (core-prim .  open-output-string)]
        [get-output-string  get-output-string-label  (core-prim .  get-output-string)]
        [close-input-port  close-input-port-label  (core-prim .  close-input-port)]
        [console-input-port  console-input-port-label  (core-prim .  console-input-port)]
        [console-output-port console-output-port-label (core-prim .  console-output-port)]
        [current-input-port  current-input-port-label  (core-prim .  current-input-port)]
        [current-output-port current-output-port-label (core-prim .  current-output-port)]
        [standard-input-port  standard-input-port-label  (core-prim .  standard-input-port)]
        [standard-output-port standard-output-port-label (core-prim .  standard-output-port)]
        [standard-error-port  standard-error-port-label  (core-prim .  standard-error-port)]
        [flush-output-port   flush-output-port-label   (core-prim .  flush-output-port)]
        [reset-input-port!   reset-input-port!-label   (core-prim .  reset-input-port!)]
        ;;; IO/high-level
        [display    display-label    (core-prim . display)]
        [write      write-label      (core-prim . write)]
        [write-char write-char-label (core-prim . write-char)]
        [read       read-label       (core-prim . read)]
        [read-char  read-char-label  (core-prim . read-char)]
        [read-token  read-token-label  (core-prim . read-token)]
        [peek-char  peek-char-label  (core-prim . peek-char)]
        [unread-char  unread-char-label  (core-prim . unread-char)]
        [newline    newline-label    (core-prim . newline)]
        [printf     printf-label     (core-prim . printf)]
        [format     format-label     (core-prim . format)]
        [pretty-print pretty-print-label (core-prim . pretty-print)]
        [comment-handler comment-handler-label (core-prim . comment-handler)]
        [print-gensym print-gensym-label (core-prim . print-gensym)]
        [gensym-count       gensym-count-label       (core-prim . gensym-count)]
        [gensym-prefix       gensym-prefix-label       (core-prim . gensym-prefix)]
        ;;; hash tables
        [make-hash-table make-hash-table-label (core-prim . make-hash-table)]
        [hash-table?      hash-table?-label      (core-prim . hash-table?)]
        [get-hash-table get-hash-table-label (core-prim . get-hash-table)]
        [put-hash-table! put-hash-table!-label (core-prim . put-hash-table!)]
        ;;; evaluation / control
        [make-parameter      make-parameter-label      (core-prim . make-parameter)]
        [apply      apply-label      (core-prim . apply)]
        [values     values-label     (core-prim . values)]
        [call-with-values cwv-label  (core-prim . call-with-values)]
        [current-eval current-eval-label (core-prim . current-eval)]
        [call/cc     call/cc-label   (core-prim . call/cc)]
        [call/cf     call/cf-label   (core-prim . call/cf)]
        [dynamic-wind dynamic-wind-label (core-prim . dynamic-wind)]
        [error      error-label      (core-prim . error)]
        [print-error print-error-label (core-prim . print-error)]
        [error-handler error-handler-label (core-prim .  error-handler)]
        [interrupt-handler interrupt-handler-label (core-prim .  interrupt-handler)]
        [exit       exit-label       (core-prim . exit)]
        [compile    compile-label    (core-prim . compile)]
        [eval       eval-label       (core-prim . eval)]
        [load       load-label       (core-prim . load)]
        [new-cafe   new-cafe-label   (core-prim . new-cafe)]
        [command-line-arguments command-line-arguments-label (core-prim .  command-line-arguments)]
        ;;; record/mid-level
        [record?                 record?-label                 (core-prim . record?)]
        [make-record-type        make-record-type-label        (core-prim . make-record-type)]
        [record-type-descriptor  record-type-descriptor-label  (core-prim . record-type-descriptor)]
        [record-type-field-names record-type-field-names-label (core-prim . record-type-field-names)]
        [record-type-symbol      record-type-symbol-label      (core-prim . record-type-symbol)]
        [record-type-name        record-type-name-label        (core-prim . record-type-name)]
        [record-name             record-name-label             (core-prim . record-name)]
        [record-constructor      record-constructor-label      (core-prim . record-constructor)]
        [record-predicate        record-predicate-labe         (core-prim . record-predicate)]
        [record-length           record-length-label           (core-prim . record-length)]
        [record-printer          record-printer-label          (core-prim . record-printer)]
        [record-ref              record-ref-label              (core-prim . record-ref)]
        [record-field-accessor   record-field-accessor-label   (core-prim . record-field-accessor)]
        [record-field-mutator    record-field-mutator-label    (core-prim . record-field-mutator)]
        ;;; records/low-level 
        [$base-rtd    $base-rtd-label    (core-prim . $base-rtd)]
        [$record-set! $record-set!-label (core-prim . $record-set!)]
        [$record-ref  $record-ref-label  (core-prim . $record-ref)]
        [$record-rtd  $record-rtd-label  (core-prim . $record-rtd)]
        [$record      $record-label      (core-prim . $record)]
        [$make-record $make-record-label (core-prim . $make-record)]
        [$record?     $record?-label     (core-prim . $record?)]
        [$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)]
        ;;; codes
        [$closure-code  $closure-code-label (core-prim . $closure-code)]
        [$code? $code?-label (core-prim . $code?)]
        [$code-reloc-vector $code-reloc-vector-label (core-prim . $code-reloc-vector)]
        [$code-freevars $code-freevars-label (core-prim . $code-freevars)]
        [$code-size $code-size-label (core-prim . $code-size)]
        [$code-ref $code-ref-label (core-prim . $code-ref)]
        [$code-set! $code-set!-label (core-prim . $code-set!)]
        [code? code?-label (core-prim . code?)]
        [code-reloc-vector code-reloc-vector-label (core-prim . code-reloc-vector)]
        [code-size code-size-label (core-prim . code-size)]
        [code-freevars code-freevars-label (core-prim . code-freevars)]
        [code-ref code-ref-label (core-prim . code-ref)]
        [code-set! code-set!-label (core-prim . code-set!)]
        ;;; tcbuckets
        [$make-tcbucket     $make-tcbucket-label    (core-prim . $make-tcbucket)]
        [$tcbucket-key     $tcbucket-key-label    (core-prim . $tcbucket-key)]
        [$tcbucket-val     $tcbucket-val-label    (core-prim . $tcbucket-val)]
        [$tcbucket-next     $tcbucket-next-label    (core-prim . $tcbucket-next)]
        [$set-tcbucket-val! $set-tcbucket-val!-label (core-prim . $set-tcbucket-val!)]
        [$set-tcbucket-next! $set-tcbucket-next!-label (core-prim . $set-tcbucket-next!)]
        [$set-tcbucket-tconc! $set-tcbucket-tconc!-label (core-prim . $set-tcbucket-tconc!)]
        ;;; misc
        [immediate?     immediate?-label    (core-prim . immediate?)]
        [pointer-value     pointer-value-label    (core-prim . pointer-value)]
        [$forward-ptr?     $forward-ptr?-label    (core-prim . $forward-ptr?)]
        ;;; junk that should go away
        [$unbound-object?     $unbound-object?-label    (core-prim . $unbound-object?)]
        [$make-call-with-values-procedure $make-cwv-procedure (core-prim . $make-call-with-values-procedure)]
        [$make-values-procedure $make-values-procedure (core-prim . $make-values-procedure)]
        [primitive-set! primitive-set!-label (core-prim . primitive-set!)]
        [primitive? primitive?-label (core-prim .  primitive?)]
        [primitive-ref primitive-ref-label (core-prim .  primitive-ref)]
        [$$apply     $$apply-label    (core-prim . $$apply)]
        [$arg-list     $arg-list-label    (core-prim . $arg-list)]
        [$fp-at-base     $fp-at-base-label    (core-prim . $fp-at-base)]
        [$primitive-call/cc     $primitive-call/cc-label    (core-prim . $primitive-call/cc)]
        [$frame->continuation     $frame->continuation-label    (core-prim . $frame->continuation)]
        [$current-frame     $current-frame-label    (core-prim . $current-frame)]
        [$seal-frame-and-call     $seal-frame-and-call-label    (core-prim . $seal-frame-and-call)]
        ))
    (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* ...)
           (let f ([lhs* lhs*] [rhs* rhs*]
                   [subst-lhs* '()] [subst-lab* '()]
                   [r r])
             (cond
               [(null? lhs*) 
                (chi-internal
                  (add-subst 
                    (id/label-rib subst-lhs* subst-lab*)
                    (cons b b*))
                  r mr)]
               [else
                (let ([lhs (car lhs*)]
                      [rhs (chi-expr
                             (add-subst
                               (id/label-rib subst-lhs* subst-lab*)
                               (car rhs*))
                             r mr)])
                  (unless (id? lhs)
                    (stx-error lhs "invalid binding"))
                  (let ([lex (gen-lexical lhs)]
                        [lab (gen-label lhs)])
                    (build-let no-source (list lex) (list rhs)
                      (f (cdr lhs*) (cdr rhs*)
                         (cons lhs subst-lhs*) 
                         (cons lab subst-lab*)
                         (add-lexicals (list lab) (list lex) r)))))]))])))
    (define letrec-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ ([lhs* rhs*] ...) b b* ...) 
           (if (not (valid-bound-ids? lhs*))
               (stx-error e)
               (let ([lex* (map gen-lexical lhs*)]
                     [lab* (map gen-label lhs*)])
                 (let ([rib (id/label-rib lhs* lab*)]
                       [r (add-lexicals lab* lex* r)])
                   (let ([body (chi-internal 
                                 (add-subst rib (cons b b*))
                                 r mr)]
                         [rhs* (chi-expr* 
                                 (map (lambda (x) 
                                        (add-subst rib x))
                                      rhs*)
                                 r mr)])
                     (build-letrec no-source 
                       lex* rhs* body)))))])))
    (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 when-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ test e e* ...) 
           (build-conditional no-source
             (chi-expr test r mr)
             (build-sequence no-source
               (chi-expr* (cons e e*) r mr))
             (chi-void))])))
    (define unless-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ test e e* ...) 
           (build-conditional no-source
             (chi-expr test r mr)
             (chi-void) 
             (build-sequence no-source
               (chi-expr* (cons e e*) r mr)))])))
    (define if-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ e0 e1 e2)
           (build-conditional no-source
             (chi-expr e0 r mr)
             (chi-expr e1 r mr)
             (chi-expr e2 r mr))]
          [(_ e0 e1)
           (build-conditional no-source
             (chi-expr e0 r mr)
             (chi-expr e1 r mr)
             (chi-void))])))
    (define case-transformer
      (lambda (e r mr)
        (define build-one 
          (lambda (t cls rest)
            (syntax-match cls
              [((d* ...) e e* ...)
               (build-conditional no-source
                 (build-application no-source
                   (build-primref no-source 'memv)
                   (list t (build-data no-source (strip d* '()))))
                 (build-sequence no-source
                   (chi-expr* (cons e e*) r mr))
                 rest)]
              [else (stx-error e)])))
        (define build-last 
          (lambda (t cls)
            (syntax-match cls
              [((d* ...) e e* ...)
               (build-one t cls (chi-void))]
              [(else-kwd x x* ...)
               (if (and (id? else-kwd)
                        (free-id=? else-kwd (sym->free-id 'else)))
                   (build-sequence no-source
                     (chi-expr* (cons x x*) r mr))
                   (stx-error e))]
              [else (stx-error e)])))
        (syntax-match e
          [(_ expr) 
           (build-sequence no-source 
             (list (chi-expr expr r mr) (chi-void)))]
          [(_ expr cls cls* ...)
           (let ([t (gen-lexical 't)])
             (build-let no-source 
                (list t) (list (chi-expr expr r mr))
                (let f ([cls cls] [cls* cls*])
                  (cond
                    [(null? cls*) (build-last t cls)]
                    [else
                     (build-one t cls
                       (f (car cls*) (cdr cls*)))]))))])))
    (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 (and (id? e0) 
                        (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 (and (id? e1) 
                        (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 case-lambda-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ [fmls* b* b** ...] ...)
           (let-values ([(fmls* body*)
                         (chi-lambda-clause* fmls*
                           (map cons b* b**) r mr)])
             (build-case-lambda no-source fmls* body*))])))
    (define lambda-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ fmls b b* ...)
           (let-values ([(fmls body) 
                         (chi-lambda-clause fmls 
                            (cons b b*) r mr)])
             (build-lambda no-source fmls body))])))
    (define bless
      (lambda (x)
        (let ([rib (make-scheme-rib)])
          (let f ([x x])
            (cond
              [(pair? x) 
               (cons (f (car x)) (f (cdr x)))]
              [(symbol? x) 
               (make-stx x top-mark* (list rib))]
              [else x])))))
    (define define-record-macro
      (lambda (e)
        (define enumerate
          (lambda (ls)
            (let f ([i 0] [ls ls])
              (cond
                [(null? ls) '()]
                [else (cons i (f (add1 i) (cdr ls)))]))))
        (define mkid
          (lambda (id str)
            (datum->stx id (string->symbol str))))
        (syntax-match e
          [(_ name (field* ...))
           (let* ([namestr (symbol->string (id->sym name))]
                  [fields (map id->sym field*)]
                  [fieldstr* (map symbol->string fields)]
                  [rtd (datum->stx name (make-record-type namestr fields))]
                  [constr (mkid name (format "make-~a" namestr))]
                  [pred (mkid name (format "~a?" namestr))]
                  [i* (enumerate field*)]
                  [getters
                   (map (lambda (x)
                          (mkid name (format "~a-~a" namestr x)))
                        fieldstr*)]
                  [setters
                   (map (lambda (x)
                          (mkid name (format "set-~a-~a!" namestr x)))
                        fieldstr*)])
             (bless
               `(begin
                  (define-syntax ,name (cons '$rtd ',rtd))
                  (define ,constr 
                    (lambda ,field*
                      ($record ',rtd ,@field*)))
                  (define ,pred
                    (lambda (x) ($record/rtd? x ',rtd)))
                  ,@(map (lambda (getter i)
                            `(define ,getter
                               (lambda (x)
                                 (if ($record/rtd? x ',rtd) 
                                     ($record-ref x ,i)
                                     (error ',getter
                                            "~s is not a record of type ~s"
                                            x ',rtd)))))
                         getters i*)
                  ,@(map (lambda (setter i)
                            `(define ,setter
                               (lambda (x v)
                                 (if ($record/rtd? x ',rtd) 
                                     ($record-set! x ,i v)
                                     (error ',setter
                                            "~s is not a record of type ~s"
                                            x ',rtd)))))
                         setters i*))))])))
    (define parameterize-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ () b b* ...) 
           (chi-internal (cons b b*) r mr)]
          [(_ ([olhs* orhs*] ...) b b* ...)
           (let ([lhs* (map (lambda (x) (gen-lexical 'lhs)) olhs*)]
                 [rhs* (map (lambda (x) (gen-lexical 'rhs)) olhs*)]
                 [t*   (map (lambda (x) (gen-lexical 't)) olhs*)]
                 [swap (gen-lexical 'swap)])
             (build-let no-source 
               (append lhs* rhs*)
               (append (chi-expr* olhs* r mr) (chi-expr* orhs* r mr))
               (build-let no-source 
                 (list swap)
                 (list (build-lambda no-source '() 
                         (build-sequence no-source 
                           (map (lambda (t lhs rhs) 
                                  (build-let no-source 
                                    (list t) 
                                    (list (build-application no-source
                                            (build-lexical-reference no-source lhs)
                                            '()))
                                    (build-sequence no-source 
                                      (list (build-application no-source 
                                              (build-lexical-reference no-source lhs)
                                              (list (build-lexical-reference no-source rhs)))
                                            (build-lexical-assignment no-source rhs 
                                              (build-lexical-reference no-source t))))))
                                t* lhs* rhs*))))
                 (build-application no-source
                   (build-primref no-source 'dynamic-wind)
                   (list (build-lexical-reference no-source swap)
                         (build-lambda no-source '() 
                           (chi-internal (cons b b*) r mr))
                         (build-lexical-reference no-source swap))))))])))
    (define and-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_) (build-data no-source #t)]
          [(_ e e* ...) 
           (let f ([e e] [e* e*])
             (cond
               [(null? e*) (chi-expr e r mr)]
               [else 
                (build-conditional no-source
                  (chi-expr e r mr)
                  (f (car e*) (cdr e*))
                  (build-data no-source #f))]))])))
    (define or-transformer
      (lambda (e r mr)
        (syntax-match e 
          [(_) (build-data no-source #f)]
          [(_ e e* ...)
           (let f ([e e] [e* e*])
             (cond
               [(null? e*) (chi-expr e r mr)]
               [else
                (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-lexical-reference no-source t)
                      (f (car e*) (cdr e*)))))]))])))
    (define foreign-call-transformer
      (lambda (e r mr)
        (syntax-match e
          [(_ name arg* ...)
           (build-foreign-call no-source
             (chi-expr name r mr)
             (chi-expr* arg* r mr))])))
    (define core-macro-transformer
      (lambda (name)
        (case name
          [(quote)         quote-transformer]
          [(lambda)        lambda-transformer]
          [(case-lambda)   case-lambda-transformer]
          [(let-values)    let-values-transformer]
          [(let)           let-transformer]
          [(letrec)        letrec-transformer]
          [(let*)          let*-transformer]
          [(cond)          cond-transformer]
          [(case)          case-transformer]
          [(if)            if-transformer]
          [(when)          when-transformer]
          [(unless)        unless-transformer]
          [(and)           and-transformer]
          [(or)            or-transformer]
          [(parameterize)  parameterize-transformer]
          [(foreign-call)  foreign-call-transformer]
          [else (error 'macro-transformer "cannot find ~s" name)])))
    (define macro-transformer
      (lambda (x)
        (cond
          [(procedure? x) x]
          [(symbol? x)
           (case x
             [(define-record) define-record-macro]
             [else (error 'macro-transformer 
                          "invalid macro ~s" x)])]
          [else (error 'core-macro-transformer 
                       "invalid macro ~s" x)])))
    ;;; chi procedures
    (define chi-macro 
      (lambda (p e)
        (let ([s ((macro-transformer p) (add-mark anti-mark e))])
          (add-mark (gen-mark) s))))
    (define chi-expr*
      (lambda (e* r mr)
        ;;; expand left to right
        (cond
          [(null? e*) '()]
          [else
           (let ([e (chi-expr (car e*) r mr)])
             (cons e (chi-expr* (cdr e*) r mr)))])))
    (define chi-application
      (lambda (e r mr)
        (syntax-match e 
          [(rator rands ...) 
           (let ([rator (chi-expr rator r mr)])
             (build-application no-source 
               rator
               (chi-expr* rands r mr)))])))
    (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) (chi-application e r mr)]
            [(lexical)
             (let ([lex value])
               (build-lexical-reference no-source lex))]
            [(macro) (chi-expr (chi-macro value e) r mr)]
            [(constant)
             (let ([datum value])
               (build-data no-source datum))]
            [(set!) (chi-set! e r mr)]
            [(begin) 
             (syntax-match e
               [(_ x x* ...)
                (build-sequence no-source
                  (chi-expr* (cons x x*) r mr))])]
            [else (error 'chi-expr "invalid type ~s for ~s" type
                         (strip e '())) (stx-error e)]))))
    (define chi-set!
      (lambda (e r mr)
        (syntax-match e
          [(_ x v)
           (if (id? x)
               (let-values ([(type value kwd) (syntax-type x r)])
                 (case type
                   [(lexical) 
                    (build-lexical-assignment no-source 
                      value 
                      (chi-expr v r mr))]
                   [else (stx-error e)]))
               (stx-error e))])))
    (define chi-lambda-clause
      (lambda (fmls body* r mr)
        (syntax-match fmls
          [(x* ...) 
           (if (valid-bound-ids? x*) 
               (let ([lex* (map gen-lexical x*)]
                     [lab* (map gen-label x*)])
                 (values
                   lex*
                   (chi-internal 
                     (add-subst 
                       (id/label-rib x* lab*)
                       body*)
                     (add-lexicals lab* lex* r)
                     mr)))
               (stx-error fmls "invalid fmls"))]
          [(x* ... . x)
           (if (valid-bound-ids? (cons x x*)) 
               (let ([lex* (map gen-lexical x*)]
                     [lab* (map gen-label x*)]
                     [lex (gen-lexical x)]
                     [lab (gen-label x)])
                 (values
                   (append lex* lex)
                   (chi-internal 
                     (add-subst 
                       (id/label-rib (cons x x*) (cons lab lab*))
                       body*)
                     (add-lexicals (cons lab lab*)
                                   (cons lex lex*)
                                   r)
                     mr)))
               (stx-error fmls "invalid fmls"))]
          [_ (stx-error fmls "invalid fmls")])))
    (define chi-lambda-clause*
      (lambda (fmls* body** r mr)
        (cond
          [(null? fmls*) (values '() '())]
          [else
           (let-values ([(a b)
                         (chi-lambda-clause (car fmls*) (car body**) r mr)])
             (let-values ([(a* b*)
                           (chi-lambda-clause* (cdr fmls*) (cdr body**) r mr)])
               (values (cons a a*) (cons b b*))))])))
    (define chi-rhs*
      (lambda (rhs* r mr)
        (define chi-rhs
          (lambda (rhs) 
            (case (car rhs)
              [(defun) 
               (let ([x (cdr rhs)])
                 (let ([fmls (car x)] [body* (cdr x)])
                   (let-values ([(fmls body) 
                                 (chi-lambda-clause fmls body* r mr)])
                     (build-lambda no-source fmls body))))]
              [(expr) 
               (let ([expr (cdr rhs)])
                 (chi-expr expr r mr))]
              [else (error 'chi-rhs "invalid rhs ~s" rhs)])))
        (let f ([ls rhs*])
          (cond ;;; chi in order
            [(null? ls) '()]
            [else
             (let ([a (chi-rhs (car ls))])
               (cons a (f (cdr ls))))]))))
    (define find-bound=?
      (lambda (x lhs* rhs*)
        (cond
          [(null? lhs*) #f]
          [(bound-id=? x (car lhs*)) (car rhs*)]
          [else (find-bound=? x (cdr lhs*) (cdr rhs*))])))
    (define chi-internal
      (lambda (e* r mr)
        (define return
          (lambda (init* module-init** r mr lhs* lex* rhs*)
            (let ([mod-init* (apply append (reverse module-init**))])
              (unless (valid-bound-ids? lhs*)
                (error 'chi-internal "multiple definitions"))
              (let ([rhs* (chi-rhs* rhs* r mr)]
                    [init* (chi-expr* (append mod-init* 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*] [module-init** '()] [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)]
                                [lab  (gen-label id)])
                            (extend-rib! rib id lab)
                            (f (cdr e*)
                               module-init**
                               (cons (cons lab (cons 'lexical lex)) r)
                               mr 
                               (cons id lhs*)
                               (cons lex lex*)
                               (cons rhs rhs*)
                               kwd*)))]
                       [(module)
                        (let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
                                      (chi-internal-module e r mr kwd*)])
                          (for-each
                            (lambda (id lab) (extend-rib! rib id lab))
                            m-exp-id* m-exp-lab*)
                          (f (cdr e*)
                             (cons m-init* module-init**)
                             r mr 
                             (append m-lhs* lhs*)
                             (append m-lex* lex*)
                             (append m-rhs* rhs*)
                             kwd*))]
                       [else 
                        (return e* module-init** r mr lhs* lex* rhs*)]))))])))))
    (define chi-internal-module
      (lambda (e r mr kwd*)
        (define parse-module
          (lambda (e)
            (syntax-match e
              [(_ (export* ...) b* ...)
               (unless (andmap id? export*) (stx-error e))
               (values #f export* b*)]
              [(_ name (export* ...) b* ...)
               (unless (and (id? name) (andmap id? export*)) (stx-error e))
               (values name export* b*)])))
        (let-values ([(name exp-id* e*) (parse-module e)])
          (let* ([rib (make-empty-rib)]
                 [e* (map (lambda (x) (add-subst rib x)) (syntax->list e*))])
            (define return
              (lambda (init* r mr lhs* lex* rhs* kwd*)
                (let ([exp-lab* 
                       (map (lambda (x) 
                               (or (id->label (add-subst rib x))
                                   (stx-error x "cannot find export")))
                            exp-id*)])
                  (if (not name) ;;; explicit export
                      (values lhs* lex* rhs* init* exp-id* exp-lab* r mr kwd*)
                      (let ([lab (gen-label 'module)]
                            [iface (cons exp-id* exp-lab*)])
                        (values lhs* lex* rhs* init* 
                                (list name) ;;; FIXME: module cannot
                                (list lab)  ;;;  export itself yet
                                (cons (cons lab (cons '$module iface)) r)
                                (cons (cons lab (cons '$module iface)) mr)
                                kwd*))))))
            (let f ([e* e*] [r r] [mr mr] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
              (cond
                [(null? e*) (return '() r mr lhs* lex* rhs* kwd*)]
                [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)]
                                  [lab (gen-label id)])
                              (extend-rib! rib id lab)
                              (f (cdr e*)
                                 (cons (cons lab (cons 'lexical lex)) r)
                                 mr 
                                 (cons id lhs*)
                                 (cons lex lex*)
                                 (cons rhs rhs*)
                                 kwd*)))]
                         [else 
                          (error 'chi-internal-module
                                 "cannot handle ~s"
                                 type)]))))]))))))
    (define chi-library-internal 
      (lambda (e* r rib kwd*)
        (define return
          (lambda (init* r mr lhs* lex* rhs*)
            (values init* r mr (reverse lhs*) (reverse lex*) (reverse rhs*))))
        (let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
          (cond
            [(null? e*) (return e* r mr lhs* lex* rhs*)]
            [else
             (let ([e (car e*)])
               ;(printf "chi ~s\n" 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 "cannt redefine identifier"))
                        (when (bound-id-member? id lhs*) 
                          (stx-error id "multiple definition"))
                        (let ([lex (gen-lexical id)]
                              [lab (gen-label id)])
                          (extend-rib! rib id lab)
                          (f (cdr e*)
                             (cons (cons lab (cons 'lexical lex)) r)
                             mr 
                             (cons id lhs*) (cons lex lex*) (cons rhs rhs*)
                             kwd*)))]
                     [(define-syntax)
                      (let-values ([(id rhs) (parse-define-syntax e)])
                        (when (bound-id-member? id kwd*) 
                          (syntax-error id "undefined identifier"))
                        (let ([lab (gen-label id)])
                          (let ([expanded-rhs (chi-expr rhs mr mr)])
                            (extend-rib! rib id lab)
                            (let ([b (make-eval-transformer expanded-rhs)])
                              (f (cdr e*) 
                                 (cons (cons lab b) r)
                                 (cons (cons lab b) mr) 
                                 lhs* lex* rhs* kwd*)))))] 
                     [(begin)
                      (syntax-match e
                        [(_ x* ...)
                         (f (append x* (cdr e*)) r mr lhs* lex* rhs*
                            kwd*)])]
                     [(macro)
                      (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
                         r mr lhs* lex* rhs* kwd*)]
                     [else 
                      (return e* r mr lhs* lex* 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*)]
                  [kwd* (map (lambda (sym mark*) (stx sym mark* (list rib)))
                             (rib-sym* rib) (rib-mark** rib))])
              (let-values ([(init* r mr lhs* lex* rhs*)
                            (chi-library-internal b* r rib kwd*)])
                (build-letrec no-source
                  lex* 
                  (chi-rhs* rhs* r mr)
                  (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))
    ))