ikarus/src/ikarus.syntax.ss

;;; FIXME: teach the compiler about (apply append ls) since I
;;;        used it a zillion times in this file.
;;;        other primitives that are usually apply'd include the
;;;        arithmetic operations (+, =, min, max, ...).
;;;        (apply (lambda ---) ls) is also common in this file.

(library (ikarus syntax)
  (export identifier? syntax-dispatch environment environment? 
          eval expand generate-temporaries free-identifier=?
          bound-identifier=? syntax-error datum->syntax
          syntax->datum make-variable-transformer
          eval-r6rs-top-level boot-library-expand eval-top-level
          null-environment)
  (import
    (r6rs)
    (except (ikarus library-manager) installed-libraries)
    (only (ikarus system $bootstrap) eval-core)
    (chez modules)
    (ikarus symbols)
    (ikarus parameters)
    (only (ikarus) error printf ormap andmap cons* format
          make-record-type void set-rtd-printer! type-descriptor
          pretty-print)
    (only (r6rs syntax-case) syntax-case syntax with-syntax)
    (prefix (r6rs syntax-case) sys:))
  (define who 'expander)
  (define-syntax no-source
    (lambda (x) #f))
  (begin ;;; builders
    (define-syntax build-application
      (syntax-rules ()
        ((_ ae fun-exp arg-exps)
         `(,fun-exp . ,arg-exps))))
    (define-syntax build-conditional
      (syntax-rules ()
        ((_ ae test-exp then-exp else-exp)
         `(if ,test-exp ,then-exp ,else-exp))))
    (define-syntax build-lexical-reference
      (syntax-rules ()
        ((_ ae var) var)
        ((_ type ae var) var)))
    (define-syntax build-lexical-assignment
      (syntax-rules ()
        ((_ ae var exp) `(set! ,var ,exp))))
    (define-syntax build-global-reference
      (syntax-rules ()
        [(_ ae var) `(top-level-value ',var)]))
    (define-syntax build-global-assignment
      (syntax-rules ()
        [(_ ae var exp) `(#%set-top-level-value! ',var ,exp)]))
    (define-syntax build-global-definition
      (syntax-rules ()
        [(_ ae var exp) (build-global-assignment ae var exp)]))
    (define-syntax build-lambda
      (syntax-rules ()
        [(_ ae vars exp) `(case-lambda [,vars ,exp])]))
    (define build-case-lambda
      (lambda (ae vars* exp*)
        `(case-lambda . ,(map list vars* exp*))))
    (define build-let
      (lambda (ae lhs* rhs* body)
        `((case-lambda [,lhs* ,body]) . ,rhs*)))
    (define-syntax build-primref
      (syntax-rules ()
        [(_ ae name)   (build-primref ae 1 name)]
        [(_ ae level name) `(|#primitive| ,name)]))
    (define-syntax build-foreign-call
      (syntax-rules ()
        [(_ ae name arg*) `(foreign-call ,name . ,arg*)]))
    (define-syntax build-data
      (syntax-rules ()
        ((_ ae exp) `',exp)))
    (define build-sequence
      (lambda (ae exps)
        (let loop ((exps exps))
          (if (null? (cdr exps))
              (car exps)
              (if (equal? (car exps) '(#%void))
                  (loop (cdr exps))
                  `(begin ,@exps))))))
    (define build-void
      (lambda () '(#%void)))
    (define build-letrec
      (lambda (ae vars val-exps body-exp)
        (if (null? vars) body-exp `(letrec ,(map list vars val-exps) ,body-exp))))
    (define build-letrec*
      (lambda (ae vars val-exps body-exp)
        (if (null? vars) body-exp `(letrec* ,(map list vars val-exps) ,body-exp)))))
  (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-global x) (gen-lexical x))
  (define gen-label
    (lambda (_) (gensym)))
  (define-record rib (sym* mark** label* sealed/freq))
  (define make-full-rib
    (lambda (id* label*)
      (make-rib (map id->sym id*) (map stx-mark* id*) label* #f)))
  (define make-empty-rib
    (lambda ()
      (make-rib '() '() '() #f)))
  (define extend-rib!
    (lambda (rib id label)
      (if (rib? rib)
          (let ([sym (id->sym id)] [mark* (stx-mark* id)])
            (when (rib-sealed/freq rib)
              (error 'extend-rib! "rib ~s is sealed" rib))
            (set-rib-sym*! rib (cons sym (rib-sym* rib)))
            (set-rib-mark**! rib (cons mark* (rib-mark** rib)))
            (set-rib-label*! rib (cons label (rib-label* rib))))
          (error 'extend-rib! "~s is not a rib" rib))))
  (define (extend-rib/check! rib id label)
    (cond
      [(rib? rib)
       (when (rib-sealed/freq rib)
         (error 'extend-rib/check! "rib ~s is sealed" rib))
       (let ([sym (id->sym id)] [mark* (stx-mark* id)])
         (let ([sym* (rib-sym* rib)])
           (when (and (memq sym (rib-sym* rib))
                      (bound-id=? id
                        (stx sym mark* (list rib))))
             (stx-error id "cannot redefine"))
           (set-rib-sym*! rib (cons sym sym*))
           (set-rib-mark**! rib (cons mark* (rib-mark** rib)))
           (set-rib-label*! rib (cons label (rib-label* rib)))))]
      [else (error 'extend-rib/check! "~s is not a rib" rib)]))
  (module (make-stx stx? stx-expr stx-mark* stx-subst*)
    (define-record stx (expr mark* subst*))
    (set-rtd-printer! (type-descriptor stx)
      (lambda (x p)
        (display "#<syntax " p)
        (write (stx->datum x) p)
        (display ">" p))))
  (define (seal-rib! rib)
    (let ([sym* (rib-sym* rib)])
      (unless (null? sym*)
        ;;; only seal if rib is not empty.
        (let ([sym* (list->vector sym*)])
          (set-rib-sym*! rib sym*)
          (set-rib-mark**! rib
            (list->vector (rib-mark** rib)))
          (set-rib-label*! rib
            (list->vector (rib-label* rib)))
          (set-rib-sealed/freq! rib
            (make-vector (vector-length sym*) 0))))))
  (define (unseal-rib! rib)
    (when (rib-sealed/freq rib)
      (set-rib-sealed/freq! rib #f)
      (set-rib-sym*! rib (vector->list (rib-sym* rib)))
      (set-rib-mark**! rib (vector->list (rib-mark** rib)))
      (set-rib-label*! rib (vector->list (rib-label* rib)))))
  (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 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-vector->list
    (lambda (x)
      (cond
        [(stx? x)
         (let ([ls (syntax-vector->list (stx-expr x))]
               [m* (stx-mark* x)] [s* (stx-subst* x)])
           (map (lambda (x) (stx x m* s*)) ls))]
        [(vector? x) (vector->list x)]
        [else (error 'syntax-vector->list "not a syntax vector ~s" x)])))
  (define syntax-pair?
    (lambda (x) (syntax-kind? x pair?)))
  (define syntax-vector?
    (lambda (x) (syntax-kind? x vector?)))
  (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 stx->datum
    (lambda (x)
      (strip x '())))
  (define extend-env
    (lambda (lab b r)
      (cons (cons lab b) r)))
  (define extend-env*
    (lambda (lab* b* r)
      (append (map cons lab* b*) r)))
  (define cons-id
    (lambda (kwd kwd*)
      (if (id? kwd)
          (cons kwd kwd*)
          kwd*)))
  (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 (increment-rib-frequency! rib idx)
    (let ([freq* (rib-sealed/freq rib)])
      (let ([freq (vector-ref freq* idx)])
        (let ([i
               (let f ([i idx])
                 (cond
                   [(zero? i) 0]
                   [else
                    (let ([j (- i 1)])
                      (cond
                        [(= freq (vector-ref freq* j)) (f j)]
                        [else i]))]))])
          (vector-set! freq* i (+ freq 1))
          (unless (= i idx)
            (let ([sym* (rib-sym* rib)]
                  [mark** (rib-mark** rib)]
                  [label* (rib-label* rib)])
              (let ([sym (vector-ref sym* idx)])
                (vector-set! sym* idx (vector-ref sym* i))
                (vector-set! sym* i sym))
              (let ([mark* (vector-ref mark** idx)])
                (vector-set! mark** idx (vector-ref mark** i))
                (vector-set! mark** i mark*))
              (let ([label (vector-ref label* idx)])
                (vector-set! label* idx (vector-ref label* i))
                (vector-set! label* i label))))))))
  (define interaction-library 
    (make-parameter #f))
  (define id->label
    (lambda (id)
      (let ([sym (id->sym id)])
        (let search ([subst* (stx-subst* id)] [mark* (stx-mark* id)])
          (cond
            [(null? subst*) 
             (cond
               [(interaction-library) =>
                (lambda (lib)
                  (cond
                    [(assq sym (library-subst lib)) => cdr]
                    [else
                     (let ([subst (library-subst 
                                    (find-library-by-name '(ikarus)))])
                       (cond
                         [(assq sym subst) =>
                          (lambda (sym/lab)
                            (let ([label (cdr sym/lab)])
                              (extend-library-subst! lib sym label)
                              label))]
                         [else
                          (let ([label (gen-label sym)])
                            (extend-library-subst! lib sym label)
                            (extend-library-env! lib label 
                              (cons 'global (cons lib (gen-global sym))))
                            label)]))]))]
               [else #f])]
            [(eq? (car subst*) 'shift)
             (search (cdr subst*) (cdr mark*))]
            [else
             (let ([rib (car subst*)])
               (cond
                 [(rib-sealed/freq rib)
                  (let ([sym* (rib-sym* rib)])
                    (let f ([i 0] [n (- (vector-length sym*) 1)])
                      (cond
                        [(and (eq? (vector-ref sym* i) sym)
                              (same-marks? mark*
                                (vector-ref (rib-mark** rib) i)))
                          (let ([label (vector-ref (rib-label* rib) i)])
                            (increment-rib-frequency! rib i)
                            label)]
                        [(= i n) (search (cdr subst*) mark*)]
                        [else (f (+ i 1) n)])))]
                 [else
                  (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
        [(imported-label->binding x)]
        [(assq x r) => cdr]
        [else (cons 'displaced-lexical #f)])))
  (define make-binding cons)
  (define binding-type car)
  (define binding-value cdr)
  (define local-binding-value cadr)
  (define local-macro-src cddr)
  (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 macro global local-macro
                 global-macro displaced-lexical syntax import
                 $module)
                (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
                      local-macro global-macro module set!
                      let-syntax letrec-syntax import)
                    (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-syntax stx-error
    (lambda (x)
      (syntax-case x ()
        [(_ stx) #'(error #f "invalid syntax ~s" (strip stx '()))]
        [(_ stx msg) #'(error #f "~a ~s" msg (strip stx '()))])))
  (define sanitize-binding
    (lambda (x src)
      (cond
        [(procedure? x) (cons* 'local-macro x src)]
        [(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
         (cons* 'local-macro! (cdr x) src)]
        [(and (pair? x) (eq? (car x) '$rtd)) x]
        [else (error 'expand "invalid transformer ~s" x)])))
  (define make-variable-transformer
    (lambda (x) 
      (if (procedure? x) 
          (cons 'macro! x)
          (error 'make-variable-transformer
                 "~s is not a procedure" x))))
  (define make-eval-transformer
    (lambda (x)
      (sanitize-binding (eval-core x) x)))
  (define-syntax syntax-match
    (lambda (ctx)
      (define dots?
        (lambda (x)
          (and (sys:identifier? x)
               (sys:free-identifier=? x #'(... ...)))))
      (define free-identifier-member?
        (lambda (x ls)
          (and (ormap (lambda (y) (sys:free-identifier=? x y)) ls) #t)))
      (define (parse-clause lits cls)
        (define (parse-pat pat)
          (syntax-case pat ()
            [id (sys:identifier? #'id)
             (cond
               [(free-identifier-member? #'id lits)
                (values '()
                  #'(lambda (x)
                       (and (id? x)
                         (free-id=? x (scheme-stx 'id))
                         '())))]
               [(sys:free-identifier=? #'id #'_)
                (values '() #'(lambda (x) '()))]
               [else
                (values (list #'id) #'(lambda (x) (list x)))])]
            [(pat dots) (dots? #'dots)
             (let-values ([(pvars decon) (parse-pat #'pat)])
               (with-syntax ([(v* ...) pvars] [decon decon])
                 (values pvars
                   #'(letrec ([f (lambda (x)
                                   (cond
                                     [(syntax-pair? x)
                                      (let ([cars/f (decon (syntax-car x))])
                                        (and cars/f
                                          (let ([cdrs/f (f (syntax-cdr x))])
                                            (and cdrs/f
                                              (map cons cars/f cdrs/f)))))]
                                     [(syntax-null? x)
                                      (list (begin 'v* '()) ...)]
                                     [else #f]))])
                       f))))]
            [(pat dots . last) (dots? #'dots)
             (let-values ([(p1 d1) (parse-pat #'pat)]
                          [(p2 d2) (parse-pat #'last)])
               (with-syntax ([(v* ...) (append p1 p2)]
                             [(v1* ...) p1]
                             [(v2* ...) p2]
                             [d1 d1] [d2 d2])
                 (values (append p1 p2)
                   #'(letrec ([f (lambda (x)
                                   (cond
                                     [(syntax-pair? x)
                                      (let ([cars/f (d1 (syntax-car x))])
                                        (and cars/f
                                          (let ([d/f (f (syntax-cdr x))])
                                            (and d/f
                                              (cons (map cons cars/f (car d/f))
                                                    (cdr d/f))))))]
                                     [else
                                      (let ([d (d2 x)])
                                        (and d
                                          (cons (list (begin 'v1* '()) ...)
                                                d)))]))])
                       (lambda (x)
                         (let ([x (f x)])
                           (and x (append (car x) (cdr x)))))))))]
            [(pat1 . pat2)
             (let-values ([(p1 d1) (parse-pat #'pat1)]
                          [(p2 d2) (parse-pat #'pat2)])
               (with-syntax ([d1 d1] [d2 d2])
                 (values (append p1 p2)
                    #'(lambda (x)
                        (and (syntax-pair? x)
                          (let ([q (d1 (syntax-car x))])
                            (and q
                              (let ([r (d2 (syntax-cdr x))])
                                (and r (append q r))))))))))]
            [#(pats ...)
             (let-values ([(pvars d) (parse-pat #'(pats ...))])
                (with-syntax ([d d])
                  (values pvars
                    #'(lambda (x)
                        (and (syntax-vector? x)
                             (d (syntax-vector->list x)))))))]
            [datum
             (values '()
               #'(lambda (x)
                   (and (equal? (strip x '()) 'datum) '())))]))
        (syntax-case cls ()
          [(pat body)
           (let-values ([(pvars decon) (parse-pat #'pat)])
             (with-syntax ([(v* ...) pvars])
               (values decon
                       #'(lambda (v* ...) #t)
                       #'(lambda (v* ...) body))))]
          [(pat guard body)
           (let-values ([(pvars decon) (parse-pat #'pat)])
             (with-syntax ([(v* ...) pvars])
               (values decon
                       #'(lambda (v* ...) guard)
                       #'(lambda (v* ...) body))))]))
      (syntax-case ctx ()
        [(_ expr (lits ...)) (andmap sys:identifier? #'(lits ...))
         #'(stx-error expr "invalid syntax")]
        [(_ expr (lits ...) cls cls* ...) (andmap sys:identifier? #'(lits ...))
         (let-values ([(decon guard body)
                       (parse-clause #'(lits ...) #'cls)])
           (with-syntax ([decon decon] [guard guard] [body body])
             #'(let ([t expr])
                 (let ([ls/false (decon t)])
                   (if (and ls/false (apply guard ls/false))
                       (apply body ls/false)
                       (syntax-match t (lits ...) cls* ...))))))])))
  (define parse-define
    (lambda (x)
      (syntax-match x ()
        [(_ (id . fmls) b b* ...) (id? id)
         (values id (cons 'defun (cons fmls (cons b b*))))]
        [(_ id val) (id? id)
         (values id (cons 'expr val))])))
  (define parse-define-syntax
    (lambda (x)
      (syntax-match x ()
        [(_ id val) (id? id) (values id val)])))
  (define scheme-stx
    (lambda (sym)
      (let ([subst
             (library-subst
               (find-library-by-name '(ikarus system $all)))])
        (cond
          [(assq sym subst) =>
           (lambda (x)
             (let ([name (car x)] [label (cdr x)])
               (add-subst
                 (make-rib (list name) (list top-mark*) (list label) #f)
                 (stx sym top-mark* '()))))]
          [else (stx sym top-mark* '())]))))
  ;;; macros
  (define add-lexical
    (lambda (lab lex r)
      (cons (cons* lab 'lexical lex) r)))
  ;;;
  (define add-lexicals
    (lambda (lab* lex* r)
      (cond
        [(null? lab*) r]
        [else
         (add-lexicals (cdr lab*) (cdr lex*)
           (add-lexical (car lab*) (car lex*) r))])))
  ;;;
  (define let-values-transformer ;;; go away
    (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
                         (make-full-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*)))))])))))])))
  (module (letrec-transformer letrec*-transformer)
    (define helper
      (lambda (e r mr letrec?)
        (syntax-match e ()
          [(_ ([lhs* rhs*] ...) b b* ...)
           (if (not (valid-bound-ids? lhs*))
               (stx-error e "invalid identifiers")
               (let ([lex* (map gen-lexical lhs*)]
                     [lab* (map gen-label lhs*)])
                 (let ([rib (make-full-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)])
                     ((if letrec? build-letrec build-letrec*)
                       no-source lex* rhs* body)))))])))
    (define letrec-transformer
      (lambda (e r mr) (helper e r mr #t)))
    (define letrec*-transformer
      (lambda (e r mr) (helper e r mr #f))))
  (define type-descriptor-transformer
    (lambda (e r mr)
      (syntax-match e ()
        [(_ id) (id? id)
         (let* ([lab (id->label id)]
                [b (label->binding lab r)]
                [type (binding-type b)])
           (unless lab (stx-error e "unbound identifier"))
           (case type
             [($rtd)
              (build-data no-source (binding-value b))]
             [else (stx-error e "invalid type")]))])))
  (define when-transformer ;;; go away
    (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))
           (build-void))])))
  (define unless-transformer ;;; go away
    (lambda (e r mr)
      (syntax-match e ()
        [(_ test e e* ...)
         (build-conditional no-source
           (chi-expr test r mr)
           (build-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)
           (build-void))])))
  (define case-transformer ;;; go away
    (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 (build-void))]
            [(else-kwd x x* ...)
             (if (and (id? else-kwd)
                      (free-id=? else-kwd (scheme-stx 'else)))
                 (build-sequence no-source
                   (chi-expr* (cons x x*) r mr))
                 (stx-error e))]
            [else (stx-error e)])))
      (syntax-match e ()