(module kw '#%kernel
  (#%require "define.ss"
             "small-scheme.ss"
             "more-scheme.ss"
             (for-syntax '#%kernel
                         "stx.ss"
                         "small-scheme.ss"
                         "stxcase-scheme.ss"
                         "name.ss"
                         "norm-define.ss"
                         "qqstx.ss"
                         "sort.ss"))

  (#%provide new-lambda new-λ
             new-define
             new-app
             (rename *make-keyword-procedure make-keyword-procedure)
             keyword-apply
             procedure-keywords
             procedure-reduce-keyword-arity
             new-prop:procedure)
  
  ;; ----------------------------------------

  (define-values (struct:keyword-procedure make-keyword-procedure keyword-procedure?
                                           keyword-procedure-ref keyword-procedure-set!)
    (make-struct-type 'keyword-procedure #f 4 0 #f
                      (list (cons prop:checked-procedure #t))
                      (current-inspector)
                      #f
                      '(0 1 2 3)))
  (define keyword-procedure-checker (make-struct-field-accessor keyword-procedure-ref 0))
  (define keyword-procedure-proc (make-struct-field-accessor keyword-procedure-ref 1))
  (define keyword-procedure-required (make-struct-field-accessor keyword-procedure-ref 2))
  (define keyword-procedure-allowed (make-struct-field-accessor keyword-procedure-ref 3))

  (define-values (struct:keyword-method make-km keyword-method? km-ref km-set!)
    (make-struct-type 'procedure
                      struct:keyword-procedure
                      0 0 #f))

  (define (generate-arity-string proc)
    (let-values ([(req allowed) (procedure-keywords proc)]
                 [(a) (procedure-arity proc)]
                 [(keywords-desc)
                  (lambda (opt req)
                    (format "~a with keyword~a~a"
                            (if (null? (cdr req))
                                (format "an ~aargument" opt)
                                (format "~aarguments" opt))
                            (if (null? (cdr req))
                                ""
                                "s")
                            (case (length req)
                              [(1) (format " ~a" (car req))]
                              [(2) (format " ~a and ~a" (car req) (cadr req))]
                              [else
                               (let loop ([req req])
                                 (if (null? (cdr req))
                                     (format " and ~a" (car req))
                                     (format " ~a,~a" (car req)
                                             (loop (cdr req)))))])))]
                 [(method-adjust)
                  (lambda (a)
                    (if (or (okm? proc)
                            (keyword-method? proc))
                        (if (zero? a) 0 (sub1 a))
                        a))])

      (string-append
       (cond
        [(number? a) 
         (let ([a (method-adjust a)])
           (format "~a argument~a" a (if (= a 1) "" "s")))]
        [(arity-at-least? a)
         (let ([a (method-adjust (arity-at-least-value a))])
           (format "at least ~a argument~a" a (if (= a 1) "" "s")))]
        [else
         "a different number of arguments"])
       (if (null? req)
           ""
           (format " plus ~a" (keywords-desc "" req)))
       (if allowed
           (let ([others (let loop ([req req][allowed allowed])
                           (cond
                            [(null? req) allowed]
                            [(eq? (car req) (car allowed))
                             (loop (cdr req) (cdr allowed))]
                            [else
                             (cons (car allowed) (loop req (cdr allowed)))]))])
             (if (null? others)
                 ""
                 (format " plus ~a"
                         (keywords-desc "optional " others))))
           " plus arbitrary keyword arguments"))))

  ;; Constructor for a procedure with only optional keywords.
  ;; The `procedure' property dispatches to a procedure in the 
  ;; struct (which has exactly the right arity).
  (define-values (struct:okp make-optional-keyword-procedure okp? okp-ref okp-set!)
    (make-struct-type 'procedure
                      struct:keyword-procedure
                      1 0 #f
                      (list (cons prop:arity-string generate-arity-string))
                      (current-inspector) 0))

  ;; A ``method'' (for arity reporting)
  (define-values (struct:okm make-optional-keyword-method okm? okm-ref okm-set!)
    (make-struct-type 'procedure
                      struct:okp
                      0 0 #f))

  (define-values (prop:named-keyword-procedure named-keyword-procedure? keyword-procedure-name)
    (make-struct-type-property 'named-keyword-procedure))

  ;; Constructor generator for a procedure with a required keyword.
  ;; (This is used with lift-expression, so that the same constructor
  ;;  is used for each evaluation of a keyword lambda.)
  ;; The `procedure' property is a per-type method that has exactly
  ;;  the right arity, and that sends all arguments to `missing-kw'.
  (define (make-required name fail-proc method?)
    (let-values ([(s: mk ? -ref -set!)
                  (make-struct-type (string->symbol (format "procedure:~a" name))
                                    (if method?
                                        struct:keyword-method
                                        struct:keyword-procedure)
                                    0 0 #f
                                    (list (cons prop:arity-string generate-arity-string)
                                          (cons prop:named-keyword-procedure name))
                                    (current-inspector) fail-proc)])
      mk))

  ;; Allows keyword application to see into a "method"-style procedure attribute:
  (define-values (new-prop:procedure new-procedure? new-procedure-ref)
    (make-struct-type-property 'procedure #f
                               (list (cons prop:procedure values))))
  
  ;; ----------------------------------------

  (define *make-keyword-procedure
    (letrec ([make-keyword-procedure
              (case-lambda 
                [(proc) (make-keyword-procedure 
                         proc
                         (lambda args
                           (apply proc null null args)))]
                [(proc plain-proc)
                 (make-optional-keyword-procedure
                  (make-keyword-checker null #f (procedure-arity proc))
                  proc
                  null
                  #f
                  plain-proc)])])
      make-keyword-procedure))
                         
  (define (keyword-apply proc kws kw-vals . normal-argss)
    (let ([type-error
           (lambda (what which)
             (apply raise-type-error
                    'keyword-apply
                    what
                    which
                    proc
                    kws
                    kw-vals
                    normal-argss))])
      (unless (procedure? proc)
        (type-error "procedure" 0))
      (let loop ([ks kws])
        (cond
          [(null? ks) (void)]
          [(or (not (pair? ks))
               (not (keyword? (car ks))))
           (type-error "list of keywords" 1)]
          [(null? (cdr ks)) (void)]
          [(or (not (pair? (cdr ks)))
               (not (keyword? (cadr ks))))
           (loop (cdr ks))]
          [(keyword<? (car ks) (cadr ks))
           (loop (cdr ks))]
          [else (type-error "sorted list of keywords" 1)]))
      (unless (list? kw-vals)
        (type-error "list" 2))
      (unless (= (length kws) (length kw-vals))
        (raise-mismatch-error
         'keyword-apply
         (format
          "keyword list: ~e; does not match the length of the value list: "
          kws)
         kw-vals))
      (let ([normal-args
             (let loop ([normal-argss normal-argss][pos 3])
               (if (null? (cdr normal-argss))
                   (let ([l (car normal-argss)])
                     (if (list? l)
                         l
                         (type-error "list" pos)))
                   (cons (car normal-argss)
                         (loop (cdr normal-argss) (add1 pos)))))])
        (if (null? kws)
            (apply proc normal-args)
            (apply
             (keyword-procedure-extract/method kws (+ 2 (length normal-args)) proc 0)
             kws
             kw-vals
             normal-args)))))

  (define (procedure-keywords p)
    (cond
     [(keyword-procedure? p)
      (values (keyword-procedure-required p)
              (keyword-procedure-allowed p))]
     [(procedure? p)
      (let ([p2 (procedure-extract-target p)])
        (if p2
            (procedure-keywords p2)
            (if (new-procedure? p)
                (let ([v (new-procedure-ref p)])
                  (if (procedure? v)
                      (procedure-keywords v)
                      (values null null)))
                (values null null))))]
     [else (raise-type-error 'procedure-keywords
                             "procedure"
                             p)]))

  ;; ----------------------------------------
  ;; `lambda' with optional and keyword arguments
  
  (define-for-syntax (simple-args? args)
    (cond
      [(identifier? args) #t]
      [(pair? args) (and (identifier? (car args))
                         (simple-args? (cdr args)))]
      [(syntax? args) (simple-args? (syntax-e args))]
      [(null? args) #t]
      [else #f]))
  
  ;; Helper to parse the argument list.
  ;; The result is syntax:
  ;;    ((plain-id ...)           ; non-potional, non-keyword args
  ;;     (opt-id ...)             ; optional, non-keyword args
  ;;     ([id opt-expr kind] ...) ; all args, kind is one of: #:plain, #:opt, #:kw
  ;;     ([kw kw-id req?] ...)    ; kw args
  ;;     (req-kw ...)             ; required keywords (could be extracted from previous)
  ;;     rest)                    ; either () or (rest-id)
  (define-for-syntax (parse-formals stx args)
    (let* ([kw-ht (make-hasheq)]
           [check-kw (lambda (kw)
                       (when (hash-ref kw-ht (syntax-e kw) #f)
                         (raise-syntax-error
                          #f
                          "duplicate keyword for argument"
                          stx
                          kw))
                       (hash-set! kw-ht (syntax-e kw) #t))])
      (let loop ([args args] [needs-default? #f])
        (syntax-case args ()
          [id
           (identifier? (syntax id))
           #'(() () () () () (id))]
          [()
           #'(() () () () () ())]
          [(id . rest)
           (identifier? (syntax id))
           (begin
             (when needs-default?
               (raise-syntax-error
                #f "default-value expression missing" stx (syntax id)))
             (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest #f)])
               #'((id . plain) opt-ids ([id #f #:plain] . opts) kws need-kw rest)))]
          [([id default] . rest)
           (identifier? (syntax id))
           (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest #t)])
             #'(plain (id . opt-ids) ([id default #:opt] . opts) kws need-kw rest))]
          [(kw id . rest)
           (and (identifier? #'id)
                (keyword? (syntax-e #'kw)))
           (begin
             (check-kw #'kw)
             (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)])
               #'(plain opt-ids ([id #f #:kw-req] . opts) ([kw id #t] . kws) (kw . need-kw) rest)))]
          [(kw [id default] . rest)
           (and (identifier? #'id)
                (keyword? (syntax-e #'kw)))
           (begin
             (check-kw #'kw)
             (with-syntax ([(plain opt-ids opts kws need-kw rest) (loop #'rest needs-default?)])
               #'(plain opt-ids ([id default #:kw-opt] . opts) ([kw id #f] . kws) need-kw rest)))]
          [(kw)
           (keyword? (syntax-e #'kw))
           (begin
             (check-kw #'kw)
             (raise-syntax-error
              #f
              "missing argument identifier after keyword"
              stx
              #'kw))]
          [(kw bad . rest)
           (keyword? (syntax-e #'kw))
           (raise-syntax-error
            #f
            "after keyword, not an identifier or identifier with default"
            stx
            (syntax bad))]
          [(bad . rest)
           (raise-syntax-error
            #f
            "not an identifier, identifier with default, or keyword"
            stx
            (syntax bad))]
          [else
           (raise-syntax-error
            #f "bad argument sequence" stx (syntax args))]))))
  
  ;; The new `lambda' form:
  (define-syntaxes (new-lambda new-λ)
    (let ([new-lambda
           (lambda (stx)
             (if (eq? (syntax-local-context) 'expression)
                 (syntax-case stx ()
                   [(_ args body1 body ...)
                    (if (simple-args? #'args)
                        ;; Use plain old `lambda':
                        (syntax/loc stx
                          (lambda args body1 body ...))
                        ;; Handle keyword or optional arguments:
                        (with-syntax ([((plain-id ...)
                                        (opt-id ...)
                                        ([id opt-expr kind] ...)
                                        ([kw kw-id kw-req] ...)
                                        need-kw
                                        rest)
                                       (parse-formals stx #'args)])
                          (let ([dup-id (check-duplicate-identifier (syntax->list #'(id ... . rest)))])
                            (when dup-id
                              (raise-syntax-error
                               #f
                               "duplicate argument identifier"
                               stx
                               dup-id)))
                          (let* ([kws (syntax->list #'(kw ...))]
                                 [opts (syntax->list #'(opt-id ...))]
                                 [ids (syntax->list #'(id ...))]
                                 [plain-ids (syntax->list #'(plain-id ...))]
                                 [kw-reqs (syntax->list #'(kw-req ...))]
                                 [kw-args (generate-temporaries kws)]     ; to hold supplied value
                                 [kw-arg?s (generate-temporaries kws)]    ; to indicated whether it was supplied
                                 [opt-args (generate-temporaries opts)]   ; supplied value
                                 [opt-arg?s (generate-temporaries opts)]  ; whether supplied
                                 [needed-kws (sort (syntax->list #'need-kw)
                                                   (lambda (a b) (keyword<? (syntax-e a) (syntax-e b))))]
                                 [sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs)
                                                   (lambda (a b) (keyword<? (syntax-e (car a))
                                                                            (syntax-e (car b)))))]
                                 [method? (syntax-property stx 'method-arity-error)]
                                 [annotate-method (lambda (stx)
                                                    (if method?
                                                        (syntax-property stx 'method-arity-error #t)
                                                        stx))])
                            (with-syntax ([(kw-arg ...) kw-args]
                                          [(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s]
                                                                    [kw-reqs kw-reqs])
                                                           (cond
                                                            [(null? kw-arg?s) null]
                                                            [(not (syntax-e (car kw-reqs)))
                                                             (cons (car kw-arg?s) (loop (cdr kw-arg?s) (cdr kw-reqs)))]
                                                            [else (loop (cdr kw-arg?s) (cdr kw-reqs))]))]
                                          [kws-sorted sorted-kws]
                                          [(opt-arg ...) opt-args]
                                          [(opt-arg? ...) opt-arg?s]
                                          [(new-plain-id  ...) (generate-temporaries #'(plain-id ...))]
                                          [new-rest (if (null? (syntax-e #'rest))
                                                        '()
                                                        '(new-rest))]
                                          [(rest-id) (if (null? (syntax-e #'rest))
                                                         '(())
                                                         #'rest)]
                                          [rest-empty (if (null? (syntax-e #'rest))
                                                          '()
                                                          '(null))]
                                          [fail-rest (if (null? (syntax-e #'rest))
                                                         '(null)
                                                         #'rest)]
                                          [make-okp (if method?
                                                        #'make-optional-keyword-method
                                                        #'make-optional-keyword-procedure)]
                                          [method? method?]
                                          [with-kw-min-args (+ 2 (length plain-ids))]
                                          [with-kw-max-arg (if (null? (syntax-e #'rest))
                                                               (+ 2 (length plain-ids) (length opts))
                                                               #f)])
                              (let ([with-core 
                                     (lambda (result)
                                       ;; body of procedure, where all keyword and optional
                                       ;; argments come in as a pair of arguments (value and
                                       ;; whether the value is valid):
                                       (quasisyntax/loc stx
                                         ;; We need to push the certificates way down, so that
                                         ;; the `class' macro (for example) can pull it apart
                                         ;; enough to insert an additional argument.
                                         (let ([core 
                                                #,(annotate-method
                                                   (quasisyntax/loc stx
                                                     (lambda #,(syntax-property
                                                                #`(given-kws given-args
                                                                             new-plain-id ... 
                                                                             opt-arg ...
                                                                             opt-arg? ...
                                                                             . new-rest)
                                                                'certify-mode
                                                                'transparent)
                                                       ;; sort out the arguments into the user-supplied bindings,
                                                       ;; evaluating default-value expressions as needed:
                                                       (let-kws given-kws given-args kws-sorted
                                                                (let-maybe ([id opt-expr kind] ... . rest)
                                                                           (kw-arg ...) (kw-arg? ...)
                                                                           (opt-arg ...) (opt-arg? ...)
                                                                           (new-plain-id ... . new-rest)
                                                                           ;; the original body, finally:
                                                                           body1 body ...)))))])
                                           ;; entry points use `core':
                                           #,result)))]
                                    [mk-no-kws
                                     (lambda ()
                                       ;; entry point without keywords:
                                       (annotate-method
                                        (syntax/loc stx
                                          (opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...) 
                                                     () (rest-empty rest-id . rest)
                                                     ()))))]
                                    [mk-with-kws
                                     (lambda ()
                                       ;; entry point with keywords:
                                       (if (and (null? opts)
                                                (null? #'new-rest))
                                           #'core
                                           (annotate-method
                                            (syntax/loc stx
                                              (opt-cases (core) ([opt-id opt-arg opt-arg?] ...) (given-kws given-args plain-id ...) 
                                                        () (rest-empty rest-id . rest)
                                                        ())))))]
                                    [mk-kw-arity-stub
                                     (lambda ()
                                       ;; struct-type entry point for no keywords when a keyword is required
                                       (annotate-method
                                        (syntax/loc stx
                                          (fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...) 
                                                          () (rest-id . fail-rest)
                                                          ()))))])
                                (cond
                                 [(null? kws)
                                  ;; just the no-kw part
                                  (with-core (mk-no-kws))]
                                 [(null? needed-kws)
                                  ;; both parts dispatch to core
                                  (with-core
                                   (with-syntax ([kws (map car sorted-kws)]
                                                 [no-kws (let ([p (mk-no-kws)]
                                                               [n (syntax-local-infer-name stx)])
                                                           (if n
                                                               #`(let ([#,n #,p]) #,n)
                                                               p))]
                                                 [with-kws (mk-with-kws)])
                                     (syntax/loc stx
                                       (make-okp
                                        (lambda (given-kws given-argc)
                                          (and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
                                               (subset?/static given-kws 'kws)))
                                        with-kws
                                        null
                                        'kws
                                        no-kws))))]
                                 [else
                                  ;; just the keywords part dispatches to core,
                                  ;; and the other part dispatches to failure
                                  (with-core
                                   (with-syntax ([kws (map car sorted-kws)]
                                                 [needed-kws needed-kws]
                                                 [no-kws (mk-no-kws)]
                                                 [with-kws (mk-with-kws)]
                                                 [mk-id (with-syntax ([n (syntax-local-infer-name stx)]
                                                                      [call-fail (mk-kw-arity-stub)])
                                                          (syntax-local-lift-expression
                                                           #'(make-required 'n call-fail method?)))])
                                     (syntax/loc stx
                                       (mk-id
                                        (lambda (given-kws given-argc)
                                          (and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
                                               (subsets?/static 'needed-kws given-kws 'kws)))
                                        with-kws
                                        'needed-kws
                                        'kws))))]))))))])
                 #`(#%expression #,stx)))])
      (values new-lambda new-lambda)))
  
  (define (missing-kw proc . args)
    (apply
     (keyword-procedure-extract/method null 0 proc 0)
     null
     null
     args))

  ;; ----------------------------------------

  ;; Helper macro:
  ;; Steps through the list bound to `kw-args', extracting
  ;; the available values. For each keyword, this binds one
  ;; id to say whether the value is present, and one id
  ;; to the actual value (if present); if the keyword isn't
  ;; available, then the corresponding `req' is applied, which
  ;; should signal an error if the keyword is required.
  (define-syntax let-kws
    (syntax-rules ()
      [(_ kws kw-args () . body)
       (begin . body)]
      [(_ kws kw-args ([kw arg arg? #f]) . body)
       ;; last optional argument doesn't need to check as much or take as many cdrs
       (let ([arg? (pair? kws)])
         (let ([arg (if arg? (car kw-args) (void))])
           . body))]
      [(_ kws kw-args ([kw arg arg? #f] . rest) . body)
       (let ([arg? (and (pair? kws)
                        (eq? 'kw (car kws)))])
         (let ([arg (if arg? (car kw-args) (void))]
               [kws (if arg? (cdr kws) kws)]
               [kw-args (if arg? (cdr kw-args) kw-args)])
           (let-kws kws kw-args rest . body)))]
      [(_ kws kw-args ([kw arg arg? #t]) . body)
       ;; last required argument doesn't need to take cdrs
       (let ([arg (car kw-args)])
         . body)]
      [(_ kws kw-args ([kw arg arg? #t] . rest) . body)
       (let ([arg (car kw-args)]
             [kws (cdr kws)]
             [kw-args (cdr kw-args)])
         (let-kws kws kw-args rest . body))]))

  ;; Used for `req' when the keyword argument is optional:
  (define-syntax missing-ok
    (syntax-rules ()
      [(_ x y) #f]))
  
  ;; ----------------------------------------

  ;; Helper macro:
  ;; Builds up a `case-lambda' to handle the arities
  ;; possible due to optional arguments. Each clause
  ;; jumps directory to `core', where each optional
  ;; argument is split into two: a boolean argument that
  ;; indicates whether it was supplied, and an argument 
  ;; for the value (if supplied).
  (define-syntax opt-cases 
    (syntax-rules ()
      [(_ (core ...) () (base ...) () (rest-empty rest-id . rest) ())
       ;; This case only happens when there are no optional arguments
       (case-lambda
         [(base ... . rest-id)
          (core ... base ... . rest)])]
      [(_ (core ...) ([opt-id opt-arg opt-arg?]) (base ...) (done-id ...) (rest-empty rest-id . rest) clauses)
       ;; Handle the last optional argument and the rest args (if any)
       ;; at the same time.
       (case-lambda
         [(base ...) (core ... base ... (a-false done-id) ... #f (a-false done-id) ... #f . rest-empty)]
         [(base ... done-id ... opt-arg . rest-id)
          (core ... base ... done-id ... opt-arg (a-true done-id) ... #t . rest)]
         . clauses)]
      [(_ (core ...) ([opt-id opt-arg opt-arg?] more ...) (base ...) (done-id ...) (rest-empty rest-id . rest) clauses)
       ;; Handle just one optional argument, add it to the "done" sequence,
       ;; and continue generating clauses for the remaining optional arguments.
       (opt-cases (core ...) (more ...) (base ...) (done-id ... opt-id) (rest-empty rest-id . rest)
                  ([(base ... done-id ... opt-arg)
                    (core ... base ... 
                          done-id ... opt-arg (a-false more) ... 
                          (a-true done-id) ... #t (a-false more) ... . rest-empty)]
                   . clauses))]))

  ;; Helper macro:
  ;; Similar to opt-cases, but just pass all arguments along to `fail'.
  (define-syntax fail-opt-cases
    (syntax-rules ()
      [(_ (fail ...) () (base ...) () (rest-id . rest) ())
       ;; This case only happens when there are no optional arguments
       (case-lambda
         [(base ... . rest-id)
          (apply fail ... base ... . rest)])]
      [(_ (fail ...) (opt-id) (base ...) (done ...) (rest-id . rest) clauses)
       ;; Handle the last optional argument and the rest args (if any)
       ;; at the same time.
       (case-lambda
         [(base ...) (fail ... base ...)]
         [(base ... done ... opt-id . rest-id) (apply fail ... base ... done ... opt-id . rest)]
         . clauses)]
      [(_ (fail ...) (opt-id more ...) (base ...) (done ...) (rest-id . rest) clauses)
       ;; Handle just one more optional argument:
       (fail-opt-cases (fail ...) (more ...) (base ...) (done ... opt-id) (rest-id . rest)
                       ([(base ... done ... opt-arg)
                         (fail ... base ... done ... opt-arg)]
                        . clauses))]))
  
  ;; Helper macros:
  (define-syntax (a-false stx) #'#f)
  (define-syntax (a-true stx) #'#t)
  
  ;; ----------------------------------------

  ;; Helper macro:
  ;; Walks through all arguments in order, shifting supplied
  ;; optional values into the user-supplied binding, and
  ;; evaluating default-value expressions when the optional
  ;; value is not available. The binding order here is
  ;; consistent with the original order of the arguments
  ;; (where, e.g., an optional keyword argument might
  ;; precede a required argument, so the required argument
  ;; cannot be used to compute the default).
  (define-syntax let-maybe
    (syntax-rules (required)
      [(_ () () () () () () . body)
       (let () . body)]
      [(_ ([id ignore #:plain] . more) kw-args kw-arg?s opt-args opt-arg?s (req-id . req-ids) . body)
       (let ([id req-id])
         (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
      [(_ ([id expr #:opt] . more)  kw-args kw-arg?s (opt-arg . opt-args) (opt-arg? . opt-arg?s) req-ids . body)
       (let ([id (if opt-arg?
                     opt-arg
                     expr)])
         (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
      [(_ ([id expr #:kw-req] . more)  (kw-arg . kw-args) kw-arg?s opt-args opt-arg?s req-ids . body)
       (let ([id kw-arg])
         (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
      [(_ ([id expr #:kw-opt] . more)  (kw-arg . kw-args) (kw-arg? . kw-arg?s) opt-args opt-arg?s req-ids . body)
       (let ([id (if kw-arg?
                     kw-arg
                     expr)])
         (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
      [(_ (id) () () () () (req-id) . body)
       (let ([id req-id]) . body)]))

  ;; ----------------------------------------
  ;; Helper macros:
  ;;  Generate arity and keyword-checking procedure statically
  ;;  as much as is reasonable.

  (define-syntax (in-range?/static stx)
    (syntax-case stx ()
      [(_ v min #f)
       #'(v . >= . min)]
      [(_ v min max)
       (if (equal? (syntax-e #'min) (syntax-e #'max))
           #'(= v min)
           #'(and (v . >= . min) (v . <= . max)))]))
  
  (define-syntax (subset?/static stx)
    (syntax-case stx (quote)
      [(_ l1-expr '()) #'(null? l1-expr)]
      [(_ '() l2-expr) #'#t]
      [(_ l1-expr '(kw . kws)) #'(let ([l1 l1-expr])
                                   (let ([l1 (if (null? l1)
                                                 l1
                                                 (if (eq? (car l1) 'kw)
                                                     (cdr l1)
                                                     l1))])
                                     (subset?/static l1 'kws)))]
      [(_ l1-expr l2-expr) #'(subset? l1-expr l2-expr)]))

  (define-syntax (subsets?/static stx)
    (syntax-case stx (quote)
      [(_ '() l2-expr l3-expr)
       #'(subset?/static l2-expr l3-expr)]
      [(_ l1-expr l2-expr '())
       #'(subset?/static l1-expr l2-expr)]
      [(_ 'l1-elems l2-expr 'l3-elems)
       (if (equal? (map syntax-e (syntax->list #'l1-elems))
                   (map syntax-e (syntax->list #'l3-elems)))
           ;; l2 must be equal to l1/l3:
           #'(equal?/static 'l1-elems l2-expr)
           #'(subsets? 'l1-elems l2-expr 'l3-elems))]))

  (define-syntax (equal?/static stx)
    ;; Unroll loop at expansion time
    (syntax-case stx (quote)
      [(_ '() l2-expr) #'(null? l2-expr)]
      [(_ '(kw . kw-rest) l2-expr)
       #'(let ([l2 l2-expr])
           (and (pair? l2)
                (eq? (car l2) 'kw)
                (equal?/static 'kw-rest (cdr l2))))]))
  
  ;; ----------------------------------------
  ;; `define' with keyword arguments
  
  (define-syntax (new-define stx)
    (let-values ([(id rhs)
                  (normalize-definition stx #'new-lambda #t #t)])
      (quasisyntax/loc stx
        (define #,id #,rhs))))
  
  ;; ----------------------------------------
  ;; `#%app' with keyword arguments
  
  (define-syntax (new-app stx)
    (let ([l (syntax->list stx)])
      (if (not (and l
                    (pair? (cdr l))
                    (not (keyword? (syntax-e (cadr l))))
                    (ormap (lambda (x) (keyword? (syntax-e x)))
                           l)))
          ;; simple or erroneous app:
          (if (identifier? stx)
              (raise-syntax-error
               #f
               "illegal use"
               stx)
              (if (and (pair? l)
                       (null? (cdr l)))
                  (raise-syntax-error
                   #f
                   "missing procedure expression; probably originally (), which is an illegal empty application"
                   stx)
                  (quasisyntax/loc stx
                    (#%app . #,(cdr (syntax-e stx))))))
          ;; keyword app (maybe)
          (let ([exprs
                 (let ([kw-ht (make-hasheq)])
                   (let loop ([l (cddr l)])
                     (cond
                       [(null? l) null]
                       [(keyword? (syntax-e (car l)))
                        (when (hash-ref kw-ht (syntax-e (car l)) #f)
                          (raise-syntax-error
                           'application
                           "duplicate keyword in application"
                           stx
                           (car l)))
                        (hash-set! kw-ht (syntax-e (car l)) #t)        
                        (cond
                          [(null? (cdr l))
                           (raise-syntax-error
                            'application
                            "missing argument expression after keyword"
                            stx
                            (car l))]
                          [(keyword? (cadr l))
                           (raise-syntax-error
                            'application
                            "keyword in expression possition (immediately after another keyword)"
                            stx
                            (cadr l))]
                          [else
                           (cons (cadr l)
                                 (loop (cddr l)))])]
                       [else
                        (cons (car l) (loop (cdr l)))])))])
            (let ([ids (cons (or (syntax-local-infer-name stx)
                                 'procedure)
                             (generate-temporaries exprs))])
              (let loop ([l (cdr l)]
                         [ids ids]
                         [bind-accum null]
                         [arg-accum null]
                         [kw-pairs null])
                (cond
                  [(null? l)
                   (let* ([args (reverse arg-accum)]
                          [sorted-kws (sort kw-pairs 
                                            (lambda (a b)
                                              (keyword<? (syntax-e (car a))
                                                         (syntax-e (car b)))))]
                          [cnt (+ 1 (length args))])
                     (quasisyntax/loc stx
                       (let #,(reverse bind-accum)
                         ((checked-procedure-check-and-extract struct:keyword-procedure
                                                               #,(car args)
                                                               keyword-procedure-extract 
                                                               '#,(map car sorted-kws) 
                                                               #,cnt)
                          '#,(map car sorted-kws)
                          (list #,@(map cdr sorted-kws))
                          . #,(cdr args)))))]
                  [(keyword? (syntax-e (car l)))
                   (loop (cddr l)
                         (cdr ids)
                         (cons (list (car ids) (cadr l)) bind-accum)
                         arg-accum
                         (cons (cons (car l) (car ids))
                               kw-pairs))]
                  [else (loop (cdr l)
                              (cdr ids)
                              (cons (list (car ids) (car l)) bind-accum)
                              (cons (car ids) arg-accum)
                              kw-pairs)])))))))
  
  ;; Checks given kws against expected. Result is
  ;; (values missing-kw extra-kw), where both are #f if
  ;; the arguments are ok.
  (define (check-kw-args p kws)
    (let loop ([kws kws]
               [required (keyword-procedure-required p)]
               [allowed (keyword-procedure-allowed p)])
      (cond
        [(null? kws)
         (if (null? required)
             (values #f #f)
             (values (car required) #f))]
        [(and (pair? required)
              (eq? (car required) (car kws)))
         (loop (cdr kws) (cdr required) (and allowed (cdr allowed)))]
        [(not allowed) ; => all keywords are allowed
         (loop (cdr kws) required #f)]
        [(pair? allowed)
         (if (eq? (car allowed) (car kws))
             (loop (cdr kws) required (cdr allowed))
             (loop kws required (cdr allowed)))]
        [else (values #f (car kws))])))

  ;; Generates a keyword an arity checker dynamically:
  (define (make-keyword-checker req-kws allowed-kws arity)
    ;; If min-args is #f, then max-args is an arity value.
    ;; If max-args is #f, then >= min-args is accepted.
    (define-syntax (arity-check-lambda stx)
      (syntax-case stx ()
        [(_ (kws) kw-body)
         #'(cond
            [(integer? arity)
             (lambda (kws a) (and kw-body (= a arity)))]
            [(arity-at-least? arity)
             (let ([arity (arity-at-least-value arity)])
               (lambda (kws a) (and kw-body (a . >= . arity))))]
            [else
             (lambda (kws a) (and kw-body (arity-includes? arity a)))])]))
    (cond
     [(not allowed-kws)
      ;; All allowed
      (cond
       [(null? req-kws)
        ;; None required
        (arity-check-lambda (kws) #t)]
       [else
        (arity-check-lambda (kws) (subset? req-kws kws))])]
     [(null? allowed-kws)
      ;; None allowed
      (arity-check-lambda (kws) (null? kws))]
     [else
      (cond
       [(null? req-kws)
        ;; None required, just allowed
        (arity-check-lambda (kws) (subset? kws allowed-kws))]
       [else
        ;; Some required, some allowed
        (if (equal? req-kws allowed-kws)
            (arity-check-lambda 
             (kws)
             ;; All allowed are required, so check equality
             (let loop ([kws kws][req-kws req-kws])
               (if (null? req-kws)
                   (null? kws)
                   (and (eq? (car kws) (car req-kws))
                        (loop (cdr kws) (cdr req-kws))))))
            (arity-check-lambda
             (kws) 
             ;; Required is a subset of allowed
             (subsets? req-kws kws allowed-kws)))])]))
  
  (define (arity-includes? arity a)
    (cond
     [(integer? arity) (= arity a)]
     [(arity-at-least? arity)
      (a . >= . (arity-at-least-value a))]
     [else
      (ormap (lambda (ar) (arity-includes? ar a)) arity)]))
  
  (define (subset? l1 l2)
    ;; l1 and l2 are sorted
    (cond
     [(null? l1) #t]
     [(null? l2) #f]
     [(eq? (car l1) (car l2)) (subset? (cdr l1) (cdr l2))]
     [else (subset? l1 (cdr l2))]))

  (define (subsets? l1 l2 l3)
    ;; l1, l2, and l3 are sorted, and l1 is a subset of l3
    (cond
     [(null? l1) (subset? l2 l3)]
     [(null? l2) #f]
     [(null? l3) #f]
     [else (let ([v2 (car l2)])
             (cond
              [(eq? (car l1) v2) (subsets? (cdr l1) (cdr l2) (cdr l3))]
              [(eq? v2 (car l3)) (subsets? l1 (cdr l2) (cdr l3))]
              [else (subsets? l1 l2 (cdr l3))]))]))

  ;; Extracts the procedure using the keyword-argument protocol.
  ;; If `p' doesn't accept keywords, make up a procedure that
  ;; reports an error.
  (define (keyword-procedure-extract/method kws n p method-n)
    (if (and (keyword-procedure? p)
             ((keyword-procedure-checker p) kws n))
        ;; Ok:
        (keyword-procedure-proc p)
        ;; Not ok, so far:
        (let ([p2 (and (not (keyword-procedure? p))
                       (procedure? p)
                       (or (procedure-extract-target p)
                           (and (new-procedure? p) 'method)))])
          (if p2
              ;; Maybe the target is ok:
              (if (eq? p2 'method)
                  ;; Build wrapper method:
                  (let ([p3 (keyword-procedure-extract/method
                             kws (add1 n) (new-procedure-ref p) (add1 method-n))])
                    (lambda (kws kw-args . args)
                      (apply p3 kws kw-args (cons p args))))
                  ;; Recur:
                  (keyword-procedure-extract/method kws n p2 method-n))
              ;; Not ok, period:
              (lambda (kws kw-args . args)
                (define-values (missing-kw extra-kw)
                  (if (keyword-procedure? p)
                      (check-kw-args p kws)
                      (values #f (car kws))))
                (let ([n (let ([method-n
                                (+ method-n
                                   (if (or (keyword-method? p) (okm? p)) 1 0))])
                           (if (n . >= . method-n) (- n method-n) n))]
                      [args-str
                       (if (and (null? args) (null? kws))
                           "no arguments supplied"
                           ;; Hack to format arguments:
                           (with-handlers ([exn:fail?
                                            (lambda (exn)
                                              ;; the message can end with:
                                              ;; ..., given: x; given 117 arguments total
                                              ;; ..., given: x; other arguments were: 1 2 3
                                              (regexp-replace #rx"^.*? given: x; (other )?"
                                                              (exn-message exn)
                                                              ""))])
                             (apply
                              raise-type-error 'x "x" 0 'x
                              (append args (apply append (map list kws kw-args))))))]
                      [proc-name (lambda (p) (or (and (named-keyword-procedure? p)
                                                      (keyword-procedure-name p))
                                                 (object-name p)
                                                 p))])
                  (raise
                   (make-exn:fail:contract
                    (if extra-kw
                        (if (keyword-procedure? p)
                            (format
                             (string-append
                              "~a: does not expect an argument with keyword ~a; ~a")
                             (proc-name p) extra-kw args-str)
                            (format
                             (string-append
                              "~a: does not accept keyword arguments; ~a")
                             (proc-name p) args-str))
                        (if missing-kw
                            (format
                             (string-append
                              "~a: requires an argument with keyword ~a, not supplied; ~a")
                             (proc-name p) missing-kw args-str)
                            (format
                             (string-append
                              "~a: no case matching ~a non-keyword"
                              " argument~a; ~a")
                             (proc-name p)
                             (- n 2) (if (= 1 (- n 2)) "" "s") args-str)))
                    (current-continuation-marks)))))))))
  (define (keyword-procedure-extract p kws n)
    (keyword-procedure-extract/method kws n p 0))

  ;; setting procedure arity
  (define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
    (let ([plain-proc (procedure-reduce-arity (if (okp? proc)
                                                  (okp-ref proc 0) 
                                                  proc)
                                              arity)])
      (define (sorted? kws)
        (let loop ([kws kws])
          (cond
           [(null? kws) #t]
           [(null? (cdr kws)) #t]
           [(keyword<? (car kws) (cadr kws)) (loop (cdr kws))]
           [else #f])))
      (define (subset? a b)
        (cond
         [(null? a) #t]
         [(null? b) #f]
         [(eq? (car a) (car b)) (subset? (cdr a) (cdr b))]
         [(keyword<? (car a) (car b)) #f]
         [else (subset? a (cdr b))]))

      (unless (and (list? req-kw) (andmap keyword? req-kw)
                   (sorted? req-kw))
        (raise-type-error 'procedure-reduce-keyword-arity "sorted list of keywords" 
                          2 proc arity req-kw allowed-kw))
      (when allowed-kw
        (unless (and (list? allowed-kw) (andmap keyword? allowed-kw)
                     (sorted? allowed-kw))
          (raise-type-error 'procedure-reduce-keyword-arity "sorted list of keywords or #f" 
                            2 proc arity req-kw allowed-kw))
        (unless (subset? req-kw allowed-kw)
          (raise-mismatch-error 'procedure-reduce-keyword-arity 
                                "allowed-keyword list does not include all required keywords: "
                                allowed-kw)))
      (let ([old-req (if (keyword-procedure? proc)
                         (keyword-procedure-required proc)
                         null)]
            [old-allowed (if (keyword-procedure? proc)
                             (keyword-procedure-allowed proc)
                             null)])
        (unless (subset? old-req req-kw)
          (raise-mismatch-error 'procedure-reduce-keyword-arity
                                "cannot reduce required keyword set: "
                                old-req))
        (when old-allowed
          (unless (subset? req-kw old-allowed)
            (raise-mismatch-error 'procedure-reduce-keyword-arity
                                  "cannot require keywords not in original allowed set: "
                                  old-allowed))
          (unless (or (not allowed-kw)
                      (subset? allowed-kw old-allowed))
            (raise-mismatch-error 'procedure-reduce-keyword-arity
                                  "cannot allow keywords not in original allowed set: "
                                  old-allowed))))
      (let ([new-arity (let loop ([a arity])
                         (cond
                          [(integer? a) (+ a 2)]
                          [(arity-at-least? a)
                           (make-arity-at-least (+ (arity-at-least-value a) 2))]
                          [else
                           (map loop a)]))])
        (make-optional-keyword-procedure
         (make-keyword-checker req-kw allowed-kw new-arity)
         (procedure-reduce-arity (keyword-procedure-proc proc)
                                 new-arity)
         req-kw
         allowed-kw
         plain-proc)))))