  Copyright 2013  
;;
  Licensed under the Apache License , Version 2.0 ( the " License " ) ;
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;; -2.0
;;
;; Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an " AS IS " BASIS ,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper procedures for simplifying statements before cps-transforming them ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (compile-syntax-rules name reserved-words patterns)
  ;; TODO: Make the syntax rules hygenic
  (define (matches-tail-pattern? expr pattern prev-pattern)
    (if (and (pair? pattern) (equal? (car pattern) '...))
      (or (null? expr)
          (and (pair? expr)
               (matches-pattern? (car expr) prev-pattern)
               (matches-tail-pattern? (cdr expr) pattern prev-pattern)))
      (matches-pattern? expr pattern)))
  (define (matches-pattern? expr pattern)
    (cond ((symbol? pattern)
           (or (not (member pattern reserved-words)) (equal? pattern expr)))
          ((pair? pattern)
           (and (pair? expr)
                (matches-pattern? (car expr) (car pattern))
                (matches-tail-pattern?
                  (cdr expr)
                  (cdr pattern)
                  (car pattern))))
          (#t (eq? pattern expr))))
  (define (bind-pattern expr pattern)
    (cond ((symbol? pattern) (list (cons pattern expr)))
          ;; TODO: The semantics of ... are more complicated than this.
  For instance , if ( ( a b ... ) ... ) is bound to ( ( 1 2 ) ( 3 4 ) ( 5 6 ) ) ,
          ;; then the replacement (a ...) should become (1 3 5).
          ((and (pair? pattern) (equal? (cdr pattern) '(...)))
           (list (cons pattern expr)))
          ((pair? pattern)
           (append
             (bind-pattern (car expr) (car pattern))
             (bind-pattern (cdr expr) (cdr pattern))))
          (#t '())))
  (define (rewrite-pattern bindings replacement)
    (if (pair? replacement)
        (if (equal? (cdr replacement) '(...))
            (let ((binding (assoc replacement bindings)))
              (if (pair? binding) (cdr binding) replacement))
            (cons (rewrite-pattern bindings (car replacement))
                  (rewrite-pattern bindings (cdr replacement))))
      (let ((binding (assoc replacement bindings)))
        (if (pair? binding) (cdr binding) replacement))))
  (define (no-op-syntax-rules expr) expr)
  (define (make-syntax-rules patterns)
    (if (pair? patterns)
      (let ((first-rule (car patterns))
            (remaining-rules (make-syntax-rules (cdr patterns))))
        (lambda (expr)
          (if (matches-pattern? expr (car first-rule))
            (rewrite-pattern
              (bind-pattern expr (car first-rule))
              (cadr first-rule))
            (remaining-rules expr))))
      no-op-syntax-rules))
  (make-syntax-rules patterns))
(define (rewrite syntax-bindings statement)
  ;; TODO: Make nested bindings mask syntax bindings
  (define (rewrite-named-let name bindings rewritten-body)
    (cons `(letrec ((,name (lambda ,(map car bindings) ,rewritten-body)))
             ,name)
          (map (lambda (binding) (rewrite-expression (cadr binding)))
               bindings)))
  (define (rewrite-let bindings rewritten-body)
    `(let (unquote
           (map (lambda (binding)
                  `(,(car binding) ,(rewrite-expression (cadr binding))))
                bindings))
       ,rewritten-body))
  (define (rewrite-letrec bindings rewritten-body)
    `(letrec (unquote
              (map (lambda (binding)
                     `(,(car binding) ,(rewrite-expression (cadr binding))))
                   bindings))
       ,rewritten-body))
  (define (free-symbol . args)
    (letrec ((symbol-in?
               (lambda (symbol expr)
                 (if (pair? expr)
                   (or (symbol-in? symbol (car expr))
                       (symbol-in? symbol (cdr expr)))
                   (eq? symbol expr))))
             (find-symbol
               (lambda (next-id)
                 (let* ((symbol-name
                          (string-append "s_" (number->string next-id)))
                        (symbol (string->symbol symbol-name)))
                   (if (symbol-in? symbol args)
                     (find-symbol (+ next-id 1))
                     symbol)))))
      (find-symbol 0)))
  (define (rewrite-do vars test commands)
    (let ((params (map car vars))
          (first-args
            (map (lambda (var) (rewrite-expression (cadr var))) vars))
          (update-args
            (map (lambda (var)
                   (if (pair? (cddr var))
                     (rewrite-expression (caddr var))
                     (car var)))
                 vars))
          (loop-var (free-symbol vars test commands)))
      `(letrec ((,loop-var
                 (lambda ,params
                   (if ,(rewrite-expression (car test))
                     ,(cons 'begin (map rewrite-expression (cdr test)))
                     ,(cons 'begin
                            (append
                              (map rewrite-expression commands)
                              `(,(cons loop-var update-args))))))))
         ,(cons loop-var first-args))))
  (define (rewrite-quasiquote expr depth)
    (cond ((= depth 0) (rewrite-expression expr))
          ((vector? expr)
           (let ((rewritten-list
                   (rewrite-quasiquote (vector->list expr) depth)))
             (if (and (pair? rewritten-list) (eq? (car rewritten-list) 'quote))
               (list 'quote (list->vector (cadr rewritten-list)))
               (list 'list->vector rewritten-list))))
          ((not (pair? expr)) (list 'quote expr))
          ((eq? (car expr) 'quasiquote)
           (rewrite-quasiquote (cadr expr) (+ depth 1)))
          ((eq? (car expr) 'unquote)
           (rewrite-quasiquote (cadr expr) (- depth 1)))
          ((and (pair? (car expr))
                (eq? (caar expr) 'unquote-splicing)
                (= depth 1))
           `(append
              ,(rewrite-expression (cadar expr))
              ,(rewrite-quasiquote (cdr expr) depth)))
          (#t
           (let ((head (rewrite-quasiquote (car expr) depth))
                 (tail (rewrite-quasiquote (cdr expr) depth)))
             (if (and (pair? head)
                      (pair? tail)
                      (eq? (car head) 'quote)
                      (eq? (car tail) 'quote))
               (list 'quote (cons (cadr head) (cadr tail)))
               (list 'cons head tail))))))
  (define (get-definitions exprs definitions bodies return)
    (if (pair? exprs)
      (if (and (pair? (car exprs)) (eq? (caar exprs) 'define))
        (get-definitions
          (cdr exprs)
          (cons (car exprs) definitions)
          bodies
          return)
        (get-definitions
          (cdr exprs)
          definitions
          (cons (car exprs) bodies)
          return))
      (return (reverse definitions) (reverse bodies))))
  (define (get-binding definition)
    (if (pair? (cadr definition))
      `(,(caadr definition)
        ,(rewrite-expression
           (append `(lambda ,(cdadr definition)) (cddr definition))))
      `(,(cadr definition) ,(rewrite-expression (caddr definition)))))
  (define (rewrite-statements statements)
    (get-definitions
      statements
      '()
      '()
      (lambda (definitions bodies)
        (if (pair? definitions)
          `(letrec ,(map get-binding definitions)
             ,(cons 'begin (map rewrite-expression bodies)))
          (cons 'begin (map rewrite-expression bodies))))))
  (define (rewrite-pair expr)
    (cond ((eq? (car expr) 'quote) expr)
          ((eq? (car expr) 'quasiquote) (rewrite-quasiquote (cadr expr) 1))
          ((eq? (car expr) 'let)
           (if (symbol? (cadr expr))
             (rewrite-named-let
               (cadr expr)
               (caddr expr)
               (rewrite-statements (cdddr expr)))
             (rewrite-let (cadr expr) (rewrite-statements (cddr expr)))))
          ((eq? (car expr) 'letrec)
           (rewrite-letrec (cadr expr) (rewrite-statements (cddr expr))))
          ;; TODO: Support let-syntax and letrec-syntax
          ((eq? (car expr) 'do)
           (rewrite-do (cadr expr) (caddr expr) (cdddr expr)))
          ((eq? (car expr) 'define)
           (if (pair? (cadr expr))
             `(define ,(caadr expr)
                ,(rewrite-expression
                   (append `(lambda ,(cdadr expr)) (cddr expr))))
             `(define ,(cadr expr) ,(rewrite-expression (caddr expr)))))
          ((eq? (car expr) 'set!)
           `(set! ,(cadr expr) ,(rewrite-expression (caddr expr))))
          ((eq? (car expr) 'begin) (rewrite-statements (cdr expr)))
          ((eq? (car expr) 'lambda)
           `(lambda ,(cadr expr) ,(rewrite-statements (cddr expr))))
          ((eq? (car expr) 'if)
           (if (pair? (cdddr expr))
             `(if ,(rewrite-expression (cadr expr))
                ,(rewrite-expression (caddr expr))
                ,(rewrite-expression (cadddr expr)))
             `(if ,(rewrite-expression (cadr expr))
                ,(rewrite-expression (caddr expr))
                (begin))))
          (#t (map rewrite-expression expr))))
  (define (find-syntax bindings name)
    (if (pair? bindings)
      (if (eq? (caar bindings) name)
        (cadar bindings)
        (find-syntax (cdr bindings) name))
      '()))
  (define (rewrite-expression expr)
    (cond ((not (pair? expr)) expr)
          ((symbol? (car expr))
           (let ((matching-syntax (find-syntax syntax-bindings (car expr))))
             (if (null? matching-syntax)
               (rewrite-pair expr)
               (let ((rewritten-expr (matching-syntax expr)))
                 (if (equal? rewritten-expr expr)
                   (rewrite-pair rewritten-expr)
                   (rewrite-expression rewritten-expr))))))
          (#t (rewrite-pair expr))))
  (rewrite-expression statement))
(define (make-rewrite-rules syntax-bindings)
  (lambda (statement return)
    (if (and (pair? statement)
             (eq? (car statement) 'define-syntax)
             (pair? (caddr statement))
             (eq? (caar (cddr statement)) 'syntax-rules))
      (let* ((name (cadr statement))
             (rules (caddr statement))
             (reserved-words (cadr rules))
             (patterns (cddr rules)))
        (set! syntax-bindings
          (cons `(,name ,(compile-syntax-rules name reserved-words patterns))
                syntax-bindings)))
      (return (rewrite syntax-bindings statement)))))

(define initial-syntax-bindings
  '((define-syntax and
      (syntax-rules ()
        ((and) #t)
        ((and expr) expr)
        ((and expr1 expr2 ...)
         (let ((test expr1))
           (if test (and expr2 ...) test)))))
    (define-syntax or
      (syntax-rules ()
        ((or) #f)
        ((or expr) expr)
        ((or expr1 expr2 ...)
         (let ((test expr1))
           (if test test (or expr2 ...))))))
    (define-syntax cond
      (syntax-rules (=> else)
        ((cond) (begin))
        ((cond (else expr ...))
         (begin expr ...))
        ((cond (expr))
         (let ((test expr)) (if test test)))
        ((cond (expr1) expr2 ...)
         (let ((test expr)) (if test test (cond expr2 ...))))
        ((cond (expr1 => expr2))
         (let ((test expr1)) (if test (expr2 test))))
        ((cond (expr1 => expr2) expr3 ...)
         (let ((test expr1)) (if test (expr2 test) (cond expr3 ...))))
        ((cond (expr1 expr2 ...))
         (if expr1 (begin expr2 ...)))
        ((cond (expr1 expr2 ...) expr3 ...)
         (if expr1 (begin expr2 ...) (cond expr3 ...)))))
    (define-syntax let*
      (syntax-rules ()
        ((let* () expr ...) (let () expr ...))
        ((let* ((var expr1)) expr2 ...)
         (let ((var expr1)) expr2 ...))
        ((let* ((var1 expr1) (var2 expr2) ...) expr3 ...)
         (let ((var1 expr1))
           (let* ((var2 expr2) ...) expr3 ...)))))
    (define-syntax letrec*
      (syntax-rules ()
        ((letrec* () expr ...) (letrec () expr ...))
        ((letrec* ((var expr1)) expr2 ...)
         (letrec ((var expr1)) expr2 ...))
        ((letrec* ((var1 expr1) (var2 expr2) ...) expr3 ...)
         (letrec ((var1 expr1))
           (letrec* ((var2 expr2) ...) expr3 ...)))))
    (define-syntax case
      (syntax-rules (else)
        ((case expr) (begin))
        ((case expr1 (else expr2 ...))
         (begin expr2 ...))
        ((case (expr ...) clauses ...)
         (let ((key (expr ...)))
           (case key clauses ...)))
        ((case expr1 (expr2 expr3 ...))
         (if (memv expr1 'expr2)
             (begin expr3 ...)))
        ((case expr1 (expr2 expr3 ...) clauses ...)
         (if (memv expr1 'expr2)
             (begin expr3 ...)
             (case expr1 clauses ...)))))
    ))
(define initial-rewrite-rules
  (let ((rewrite-rules (make-rewrite-rules '())))
    (begin (for-each (lambda (statement)
                       (rewrite-rules statement (lambda (statement) statement)))
                     initial-syntax-bindings)
           rewrite-rules)))


 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

 -2.0

 Unless required by applicable law or agreed to in writing, software
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.

 Helper procedures for simplifying statements before cps-transforming them ;;

 TODO: Make the syntax rules hygenic
 TODO: The semantics of ... are more complicated than this.
 then the replacement (a ...) should become (1 3 5).
 TODO: Make nested bindings mask syntax bindings
 TODO: Support let-syntax and letrec-syntax
  Copyright 2013  
  distributed under the License is distributed on an " AS IS " BASIS ,
(define (compile-syntax-rules name reserved-words patterns)
  (define (matches-tail-pattern? expr pattern prev-pattern)
    (if (and (pair? pattern) (equal? (car pattern) '...))
      (or (null? expr)
          (and (pair? expr)
               (matches-pattern? (car expr) prev-pattern)
               (matches-tail-pattern? (cdr expr) pattern prev-pattern)))
      (matches-pattern? expr pattern)))
  (define (matches-pattern? expr pattern)
    (cond ((symbol? pattern)
           (or (not (member pattern reserved-words)) (equal? pattern expr)))
          ((pair? pattern)
           (and (pair? expr)
                (matches-pattern? (car expr) (car pattern))
                (matches-tail-pattern?
                  (cdr expr)
                  (cdr pattern)
                  (car pattern))))
          (#t (eq? pattern expr))))
  (define (bind-pattern expr pattern)
    (cond ((symbol? pattern) (list (cons pattern expr)))
  For instance , if ( ( a b ... ) ... ) is bound to ( ( 1 2 ) ( 3 4 ) ( 5 6 ) ) ,
          ((and (pair? pattern) (equal? (cdr pattern) '(...)))
           (list (cons pattern expr)))
          ((pair? pattern)
           (append
             (bind-pattern (car expr) (car pattern))
             (bind-pattern (cdr expr) (cdr pattern))))
          (#t '())))
  (define (rewrite-pattern bindings replacement)
    (if (pair? replacement)
        (if (equal? (cdr replacement) '(...))
            (let ((binding (assoc replacement bindings)))
              (if (pair? binding) (cdr binding) replacement))
            (cons (rewrite-pattern bindings (car replacement))
                  (rewrite-pattern bindings (cdr replacement))))
      (let ((binding (assoc replacement bindings)))
        (if (pair? binding) (cdr binding) replacement))))
  (define (no-op-syntax-rules expr) expr)
  (define (make-syntax-rules patterns)
    (if (pair? patterns)
      (let ((first-rule (car patterns))
            (remaining-rules (make-syntax-rules (cdr patterns))))
        (lambda (expr)
          (if (matches-pattern? expr (car first-rule))
            (rewrite-pattern
              (bind-pattern expr (car first-rule))
              (cadr first-rule))
            (remaining-rules expr))))
      no-op-syntax-rules))
  (make-syntax-rules patterns))
(define (rewrite syntax-bindings statement)
  (define (rewrite-named-let name bindings rewritten-body)
    (cons `(letrec ((,name (lambda ,(map car bindings) ,rewritten-body)))
             ,name)
          (map (lambda (binding) (rewrite-expression (cadr binding)))
               bindings)))
  (define (rewrite-let bindings rewritten-body)
    `(let (unquote
           (map (lambda (binding)
                  `(,(car binding) ,(rewrite-expression (cadr binding))))
                bindings))
       ,rewritten-body))
  (define (rewrite-letrec bindings rewritten-body)
    `(letrec (unquote
              (map (lambda (binding)
                     `(,(car binding) ,(rewrite-expression (cadr binding))))
                   bindings))
       ,rewritten-body))
  (define (free-symbol . args)
    (letrec ((symbol-in?
               (lambda (symbol expr)
                 (if (pair? expr)
                   (or (symbol-in? symbol (car expr))
                       (symbol-in? symbol (cdr expr)))
                   (eq? symbol expr))))
             (find-symbol
               (lambda (next-id)
                 (let* ((symbol-name
                          (string-append "s_" (number->string next-id)))
                        (symbol (string->symbol symbol-name)))
                   (if (symbol-in? symbol args)
                     (find-symbol (+ next-id 1))
                     symbol)))))
      (find-symbol 0)))
  (define (rewrite-do vars test commands)
    (let ((params (map car vars))
          (first-args
            (map (lambda (var) (rewrite-expression (cadr var))) vars))
          (update-args
            (map (lambda (var)
                   (if (pair? (cddr var))
                     (rewrite-expression (caddr var))
                     (car var)))
                 vars))
          (loop-var (free-symbol vars test commands)))
      `(letrec ((,loop-var
                 (lambda ,params
                   (if ,(rewrite-expression (car test))
                     ,(cons 'begin (map rewrite-expression (cdr test)))
                     ,(cons 'begin
                            (append
                              (map rewrite-expression commands)
                              `(,(cons loop-var update-args))))))))
         ,(cons loop-var first-args))))
  (define (rewrite-quasiquote expr depth)
    (cond ((= depth 0) (rewrite-expression expr))
          ((vector? expr)
           (let ((rewritten-list
                   (rewrite-quasiquote (vector->list expr) depth)))
             (if (and (pair? rewritten-list) (eq? (car rewritten-list) 'quote))
               (list 'quote (list->vector (cadr rewritten-list)))
               (list 'list->vector rewritten-list))))
          ((not (pair? expr)) (list 'quote expr))
          ((eq? (car expr) 'quasiquote)
           (rewrite-quasiquote (cadr expr) (+ depth 1)))
          ((eq? (car expr) 'unquote)
           (rewrite-quasiquote (cadr expr) (- depth 1)))
          ((and (pair? (car expr))
                (eq? (caar expr) 'unquote-splicing)
                (= depth 1))
           `(append
              ,(rewrite-expression (cadar expr))
              ,(rewrite-quasiquote (cdr expr) depth)))
          (#t
           (let ((head (rewrite-quasiquote (car expr) depth))
                 (tail (rewrite-quasiquote (cdr expr) depth)))
             (if (and (pair? head)
                      (pair? tail)
                      (eq? (car head) 'quote)
                      (eq? (car tail) 'quote))
               (list 'quote (cons (cadr head) (cadr tail)))
               (list 'cons head tail))))))
  (define (get-definitions exprs definitions bodies return)
    (if (pair? exprs)
      (if (and (pair? (car exprs)) (eq? (caar exprs) 'define))
        (get-definitions
          (cdr exprs)
          (cons (car exprs) definitions)
          bodies
          return)
        (get-definitions
          (cdr exprs)
          definitions
          (cons (car exprs) bodies)
          return))
      (return (reverse definitions) (reverse bodies))))
  (define (get-binding definition)
    (if (pair? (cadr definition))
      `(,(caadr definition)
        ,(rewrite-expression
           (append `(lambda ,(cdadr definition)) (cddr definition))))
      `(,(cadr definition) ,(rewrite-expression (caddr definition)))))
  (define (rewrite-statements statements)
    (get-definitions
      statements
      '()
      '()
      (lambda (definitions bodies)
        (if (pair? definitions)
          `(letrec ,(map get-binding definitions)
             ,(cons 'begin (map rewrite-expression bodies)))
          (cons 'begin (map rewrite-expression bodies))))))
  (define (rewrite-pair expr)
    (cond ((eq? (car expr) 'quote) expr)
          ((eq? (car expr) 'quasiquote) (rewrite-quasiquote (cadr expr) 1))
          ((eq? (car expr) 'let)
           (if (symbol? (cadr expr))
             (rewrite-named-let
               (cadr expr)
               (caddr expr)
               (rewrite-statements (cdddr expr)))
             (rewrite-let (cadr expr) (rewrite-statements (cddr expr)))))
          ((eq? (car expr) 'letrec)
           (rewrite-letrec (cadr expr) (rewrite-statements (cddr expr))))
          ((eq? (car expr) 'do)
           (rewrite-do (cadr expr) (caddr expr) (cdddr expr)))
          ((eq? (car expr) 'define)
           (if (pair? (cadr expr))
             `(define ,(caadr expr)
                ,(rewrite-expression
                   (append `(lambda ,(cdadr expr)) (cddr expr))))
             `(define ,(cadr expr) ,(rewrite-expression (caddr expr)))))
          ((eq? (car expr) 'set!)
           `(set! ,(cadr expr) ,(rewrite-expression (caddr expr))))
          ((eq? (car expr) 'begin) (rewrite-statements (cdr expr)))
          ((eq? (car expr) 'lambda)
           `(lambda ,(cadr expr) ,(rewrite-statements (cddr expr))))
          ((eq? (car expr) 'if)
           (if (pair? (cdddr expr))
             `(if ,(rewrite-expression (cadr expr))
                ,(rewrite-expression (caddr expr))
                ,(rewrite-expression (cadddr expr)))
             `(if ,(rewrite-expression (cadr expr))
                ,(rewrite-expression (caddr expr))
                (begin))))
          (#t (map rewrite-expression expr))))
  (define (find-syntax bindings name)
    (if (pair? bindings)
      (if (eq? (caar bindings) name)
        (cadar bindings)
        (find-syntax (cdr bindings) name))
      '()))
  (define (rewrite-expression expr)
    (cond ((not (pair? expr)) expr)
          ((symbol? (car expr))
           (let ((matching-syntax (find-syntax syntax-bindings (car expr))))
             (if (null? matching-syntax)
               (rewrite-pair expr)
               (let ((rewritten-expr (matching-syntax expr)))
                 (if (equal? rewritten-expr expr)
                   (rewrite-pair rewritten-expr)
                   (rewrite-expression rewritten-expr))))))
          (#t (rewrite-pair expr))))
  (rewrite-expression statement))
(define (make-rewrite-rules syntax-bindings)
  (lambda (statement return)
    (if (and (pair? statement)
             (eq? (car statement) 'define-syntax)
             (pair? (caddr statement))
             (eq? (caar (cddr statement)) 'syntax-rules))
      (let* ((name (cadr statement))
             (rules (caddr statement))
             (reserved-words (cadr rules))
             (patterns (cddr rules)))
        (set! syntax-bindings
          (cons `(,name ,(compile-syntax-rules name reserved-words patterns))
                syntax-bindings)))
      (return (rewrite syntax-bindings statement)))))

(define initial-syntax-bindings
  '((define-syntax and
      (syntax-rules ()
        ((and) #t)
        ((and expr) expr)
        ((and expr1 expr2 ...)
         (let ((test expr1))
           (if test (and expr2 ...) test)))))
    (define-syntax or
      (syntax-rules ()
        ((or) #f)
        ((or expr) expr)
        ((or expr1 expr2 ...)
         (let ((test expr1))
           (if test test (or expr2 ...))))))
    (define-syntax cond
      (syntax-rules (=> else)
        ((cond) (begin))
        ((cond (else expr ...))
         (begin expr ...))
        ((cond (expr))
         (let ((test expr)) (if test test)))
        ((cond (expr1) expr2 ...)
         (let ((test expr)) (if test test (cond expr2 ...))))
        ((cond (expr1 => expr2))
         (let ((test expr1)) (if test (expr2 test))))
        ((cond (expr1 => expr2) expr3 ...)
         (let ((test expr1)) (if test (expr2 test) (cond expr3 ...))))
        ((cond (expr1 expr2 ...))
         (if expr1 (begin expr2 ...)))
        ((cond (expr1 expr2 ...) expr3 ...)
         (if expr1 (begin expr2 ...) (cond expr3 ...)))))
    (define-syntax let*
      (syntax-rules ()
        ((let* () expr ...) (let () expr ...))
        ((let* ((var expr1)) expr2 ...)
         (let ((var expr1)) expr2 ...))
        ((let* ((var1 expr1) (var2 expr2) ...) expr3 ...)
         (let ((var1 expr1))
           (let* ((var2 expr2) ...) expr3 ...)))))
    (define-syntax letrec*
      (syntax-rules ()
        ((letrec* () expr ...) (letrec () expr ...))
        ((letrec* ((var expr1)) expr2 ...)
         (letrec ((var expr1)) expr2 ...))
        ((letrec* ((var1 expr1) (var2 expr2) ...) expr3 ...)
         (letrec ((var1 expr1))
           (letrec* ((var2 expr2) ...) expr3 ...)))))
    (define-syntax case
      (syntax-rules (else)
        ((case expr) (begin))
        ((case expr1 (else expr2 ...))
         (begin expr2 ...))
        ((case (expr ...) clauses ...)
         (let ((key (expr ...)))
           (case key clauses ...)))
        ((case expr1 (expr2 expr3 ...))
         (if (memv expr1 'expr2)
             (begin expr3 ...)))
        ((case expr1 (expr2 expr3 ...) clauses ...)
         (if (memv expr1 'expr2)
             (begin expr3 ...)
             (case expr1 clauses ...)))))
    ))
(define initial-rewrite-rules
  (let ((rewrite-rules (make-rewrite-rules '())))
    (begin (for-each (lambda (statement)
                       (rewrite-rules statement (lambda (statement) statement)))
                     initial-syntax-bindings)
           rewrite-rules)))