(library (rnrs control (6))
   (export when unless do case-lambda)
   (import (for (only (core primitives)
                  define-syntax ... _ if begin not lambda syntax-case syntax
                  map syntax-violation quote length assertion-violation = >=
                  apply)
             expand run) 
           (for (core let)          expand run)
           (for (core with-syntax)  expand)
           (for (core syntax-rules) expand))
   
   (define-syntax when
     (syntax-rules ()
       ((when test result1 result2 ...)
        (if test
            (begin result1 result2 ...)))))
   
   (define-syntax unless
     (syntax-rules ()
       ((unless test result1 result2 ...)
        (if (not test)
            (begin result1 result2 ...)))))
   
   (define-syntax do
     (lambda (orig-x)
       (syntax-case orig-x ()
         ((_ ((var init . step) ...) (e0 e1 ...) c ...)
          (with-syntax (((step ...)
                         (map (lambda (v s)
                                (syntax-case s ()
                                  (()  v)
                                  ((e) (syntax e))
                                  (_   (syntax-violation 'do "Invalid step" orig-x s))))
                              (syntax (var ...))
                              (syntax (step ...)))))
            (syntax-case (syntax (e1 ...)) ()
              (()          (syntax (let do ((var init) ...)
                                     (if (not e0)
                                         (begin c ... (do step ...))))))
              ((e1 e2 ...) (syntax (let do ((var init) ...)
                                     (if e0
                                         (begin e1 e2 ...)
                                         (begin c ... (do step ...))))))))))))                         
   
   (define-syntax case-lambda
     (syntax-rules ()
       ((_ (fmls b1 b2 ...))
        (lambda fmls b1 b2 ...))
       ((_ (fmls b1 b2 ...) ...)
        (lambda args
          (let ((n (length args)))
            (case-lambda-help args n
                              (fmls b1 b2 ...) ...))))))
   
   (define-syntax case-lambda-help
     (syntax-rules ()
       ((_ args n)
        (assertion-violation #f "unexpected number of arguments"))
       ((_ args n ((x ...) b1 b2 ...) more ...)
        (if (= n (length '(x ...)))
            (apply (lambda (x ...) b1 b2 ...) args)
            (case-lambda-help args n more ...)))
       ((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...)
        (if (>= n (length '(x1 x2 ...)))
            (apply (lambda (x1 x2 ... . r) b1 b2 ...)
                   args)
            (case-lambda-help args n more ...)))
       ((_ args n (r b1 b2 ...) more ...)
        (apply (lambda r b1 b2 ...) args))))                                      
   
   ) ; rnrs control