(module current-pvars '#%kernel
  (#%require version-case
             (only racket/base version))

  (#%provide (for-syntax current-pvars
                         current-pvars+unique)
             with-pvars
             define-pvars)
  
  (#%require racket/private/small-scheme
             (for-syntax '#%kernel
                         racket/private/qq-and-or
                         racket/private/stx))

  (version-case
    [(version< (version) "6.90")
  ;; This is a poor man's syntax parameter. Since the implementation of
  ;; racket/stxparam depends on syntax-case, and we want to add current-pvars to
  ;; syntax-case, we cannot use syntax parameters, lest we create a cyclic
  ;; dependency. Instead, we implement here a simplified "syntax parameter".
  ;  Like racket/stxparam, it relies on nested bindings of the same identifier,
  ;; and on syntax-local-get-shadower to access the most nested binding.

  ;; Since define/with-syntax and define/syntax-parse need to add new ids to
  ;; the list, they redefine current-pvars-param, shadowing the outer binding.
  ;; Unfortunately, if a let form contains two uses of define/with-syntax, this
  ;; would result in two redefinitions of current-pvars-param, which would cause
  ;; a "duplicate definition" error. Instead of shadowing the outer bindings, we
  ;; therefore store the list of bound syntax pattern variables in a new, fresh
  ;; identifier. When accessing the list, (current-pvars) then checks all such
  ;; identifiers. The identifiers have the form current-pvars-paramNNN and are
  ;; numbered sequentially, each new "shadowing" identifier using the number
  ;; following the latest visible identifier.
  ;; When it is safe to shadow identifiers (i.e. for with-pvars, but not for
  ;; define-pvars), current-pvars-index-lower-bound is also shadowed.
  ;; When current-pvars-index-lower-bound is bound, it contains the index of the
  ;; latest current-pvars-paramNNN at that point.
  ;; When accessing the latest current-pvars-paramNNN, a dichotomy search is
  ;; performed between current-pvars-index-lower-bound and an upper bound
  ;; computed by trying to access lower-bound + 2ᵏ, with increasing values of k,
  ;; until an unbound identifier is found.

  ;; (poor-man-parameterof exact-nonnegative-integer?)
  (define-syntaxes (current-pvars-index-lower-bound) 0)
  ;; (poor-man-parameterof (listof identifier?))
  (define-syntaxes (current-pvars-param0) '())

  (begin-for-syntax
    ;; (-> any/c (or/c (listof syntax?) #f))
    (define-values (syntax*->list)
      (λ (stxlist)
        (syntax->list (datum->syntax #f stxlist))))
    
    ;; (-> identifier? (or/c #f (listof identifier?)))
    (define-values (try-current-pvars)
      (λ (id)
        (syntax-local-value
         (syntax-local-get-shadower id
                                    #t)
         ;; Default value if we are outside of any with-pvars.
         (λ () #f))))

    ;; (-> exact-nonnegative-integer? identifier?)
    (define-values (nth-current-pvars-id)
      (λ (n)
        (syntax-local-introduce
         (datum->syntax (quote-syntax here)
                        (string->symbol
                         (format "current-pvars-param~a" n))))))
    
    ;; (-> exact-nonnegative-integer? (or/c #f (listof identifier?)))
    (define-values (try-nth-current-pvars)
      (λ (n)
        (try-current-pvars (nth-current-pvars-id n))))

    ;; (-> exact-nonnegative-integer? exact-nonnegative-integer?
    ;;     exact-nonnegative-integer?)
    ;; Doubles the value of n until (+ start n) is not a valid index
    ;; in the current-pvars-param pseudo-array
    (define-values (double-max)
      (λ (start n)
        (if (try-nth-current-pvars (+ start n))
            (double-max start (* n 2))
            (+ start n))))


    ;; (-> exact-nonnegative-integer? exact-nonnegative-integer?
    ;;     exact-nonnegative-integer?)
    ;; Preconditions: upper > lower ∧ upper - lower = 2ᵏ ∧ k ∈ ℕ
    ;; Returns the last valid index in the current-pvars-param pseudo-array,
    ;; by dichotomy between 
    (define-values (dichotomy)
      (λ (lower upper)
        (if (= (- upper lower) 1)
            (if (try-nth-current-pvars upper)
                upper ;; Technically not possible, still included for safety.
                lower)
            (let ([mid (/ (+ upper lower) 2)])
              (if (try-nth-current-pvars mid)
                  (dichotomy mid upper)
                  (dichotomy lower mid))))))

    ;; (-> exact-nonnegative-integer?)
    (define-values (find-last-current-pvars)
      (λ ()
        (let ([lower-bound (syntax-local-value
                            (syntax-local-get-shadower
                             (syntax-local-introduce
                              (quote-syntax current-pvars-index-lower-bound))
                             #t))])
          (if (not (try-nth-current-pvars (+ lower-bound 1)))
              ;; Short path for the common case where there are no uses
              ;; of define/with-syntax or define/syntax-parse in the most nested
              ;; syntax-case, with-syntax or syntax-parse
              lower-bound
              ;; Find an upper bound by repeatedly doubling an offset (starting
              ;; with 1) from the lower bound, then perform a dichotomy between
              ;; these two bounds.
              (dichotomy lower-bound
                         (double-max lower-bound 1))))))

    ;; (-> (listof identifier?))
    (define-values (current-pvars)
      (λ ()
        (map car (try-nth-current-pvars (find-last-current-pvars)))))

    (define-values (current-pvars+unique)
      (λ ()
        (try-nth-current-pvars (find-last-current-pvars)))))

  ;; (with-pvars [pvar ...] . body)
  (define-syntaxes (with-pvars)
    (lambda (stx)
      (if (not (and (stx-pair? stx)
                    (identifier? (stx-car stx))
                    (stx-pair? (stx-cdr stx))
                    (syntax*->list (stx-car (stx-cdr stx)))
                    (andmap identifier?
                            (syntax*->list (stx-car (stx-cdr stx))))))
          (raise-syntax-error 'with-pvars "bad syntax" stx)
          (void))
      (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
             [unique-at-runtime (map gensym (map syntax-e pvars))]
             [stxquoted-pvars+unique (map (λ (v unique)
                                            `(cons (quote-syntax ,v)
                                                   (quote-syntax ,unique)))
                                          pvars
                                          unique-at-runtime)]
             [body (stx-cdr (stx-cdr stx))]
             [old-pvars-index (find-last-current-pvars)]
             [old-pvars (try-nth-current-pvars old-pvars-index)]
             [binding (syntax-local-identifier-as-binding
                       (nth-current-pvars-id (+ old-pvars-index 1)))]
             [lower-bound-binding
              (syntax-local-identifier-as-binding
               (syntax-local-introduce
                (quote-syntax current-pvars-index-lower-bound)))]
             [do-unique-at-runtime (map (λ (id pvar)
                                          `[(,id) (gensym (quote ,pvar))])
                                        unique-at-runtime
                                        pvars)])
        (datum->syntax
         (quote-syntax here)
         `(let-values (,@do-unique-at-runtime)
            (letrec-syntaxes+values
                ([(,binding) (list* ,@stxquoted-pvars+unique
                                    (try-nth-current-pvars ,old-pvars-index))]
                 [(,lower-bound-binding) ,(+ old-pvars-index 1)])
              ()
              . ,body))))))

  (define-syntaxes (define-pvars)
    (lambda (stx)
      (if (not (and (stx-pair? stx)
                    (identifier? (stx-car stx))
                    (syntax*->list (stx-cdr stx))
                    (andmap identifier?
                            (syntax*->list (stx-cdr stx)))))
          (raise-syntax-error 'define-pvars "bad syntax" stx)
          (void))
      (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))]
             [unique-at-runtime (map gensym (map syntax-e pvars))]
             [stxquoted-pvars+unique (map (λ (v unique)
                                            `(cons (quote-syntax ,v)
                                                   (quote-syntax ,unique)))
                                          pvars
                                          unique-at-runtime)]
             [old-pvars-index (find-last-current-pvars)]
             [old-pvars (try-nth-current-pvars old-pvars-index)]
             [binding (syntax-local-identifier-as-binding
                       (nth-current-pvars-id (+ old-pvars-index 1)))])
        (datum->syntax
         (quote-syntax here)
         `(begin
            (define-values (,@unique-at-runtime)
              (values ,@(map (λ (pvar) `(gensym (quote ,pvar))) pvars)))
            (define-syntaxes (,binding)
              (list* ,@stxquoted-pvars+unique
                     (try-nth-current-pvars ,old-pvars-index))))))))
]
    [else
  (begin-for-syntax
    (define-values (current-pvars-param-guard)
      (lambda (x)
        ;; TODO: add condition: elements should be pairs of identifiers?
        ;; Skip the guard, otherwise each operation is O(n). TODO: use a
        ;; push/pop API which does the check on the head of the list instead.
        #;(if (list? x)
              x
              (error "current-pvars-param should be a list"))
        x))
    
    (define-values (current-pvars-param)
      (make-parameter '() current-pvars-param-guard))

    (define-values (current-pvars)
      (lambda ()
        (pop-unreachable-pvars)
        (map car (current-pvars-param))))
    
    (define-values (current-pvars+unique)
      (lambda ()
        (pop-unreachable-pvars)
        (current-pvars-param)))

    (define-values (syntax*->list)
      (λ (stxlist)
        (syntax->list (datum->syntax #f stxlist))))

    (define-values (pop-unreachable-pvars)
      (lambda ()
        (if (or (null? (current-pvars-param))
                (syntax-local-value (caar (current-pvars-param))
                                    (λ () #f)))
            (void)
            (begin
              (current-pvars-param (cdr (current-pvars-param)))
              (pop-unreachable-pvars))))))

  ;; (with-pvars [pvar ...] . body)
  (define-syntaxes (with-pvars)
    (lambda (stx)
      (if (not (and (stx-pair? stx)
                    (identifier? (stx-car stx))
                    (stx-pair? (stx-cdr stx))
                    (syntax*->list (stx-car (stx-cdr stx)))
                    (andmap identifier?
                            (syntax*->list (stx-car (stx-cdr stx))))))
          (raise-syntax-error 'with-pvars "bad syntax" stx)
          (void))
      (let* ([pvars (syntax*->list (stx-car (stx-cdr stx)))]
             [body (stx-cdr (stx-cdr stx))])
        (datum->syntax
         (quote-syntax here)
         `(let-values ()
            (define-pvars ,@pvars)
            ,@body))))
    #;(lambda (stx)
        (if (not (and (stx-pair? stx)
                      (identifier? (stx-car stx))
                      (stx-pair? (stx-cdr stx))
                      (syntax*->list (stx-car (stx-cdr stx)))
                      (andmap identifier?
                              (syntax*->list (stx-car (stx-cdr stx))))))
            (raise-syntax-error 'with-pvars "bad syntax" stx)
            (void))
        (let* ([pvars (reverse (syntax*->list (stx-car (stx-cdr stx))))]
               [unique-at-runtime (map gensym (map syntax-e pvars))]
               [pvars+unique (map cons pvars unique-at-runtime)]
               [body (stx-cdr (stx-cdr stx))]
               [do-unique-at-runtime (map (λ (id pvar)
                                            `[(,id) (gensym (quote ,pvar))])
                                          unique-at-runtime
                                          pvars)]
               [wrapped-body (datum->syntax
                              (quote-syntax here)
                              `(let-values (,@do-unique-at-runtime)
                                 ,@body))])

          (pop-unreachable-pvars)

          (with-continuation-mark
              parameterization-key
            (extend-parameterization
             (continuation-mark-set-first #f parameterization-key)
             current-pvars-param
             (append pvars+unique
                     (current-pvars-param)))
            (let-values ([(stx opaque)
                          (syntax-local-expand-expression wrapped-body #t)])
              opaque))
        
          ;; above is the manual expansion of:
          #;(parameterize ([current-pvars-param
                            (list* stxquoted-pvars+unique
                                   (current-pvars-param))])
              … syntax-local-expand-expression …))))

  ;; (define-pvars pv1 … pvn)
  (define-syntaxes (define-pvars)
    (lambda (stx)
      (if (not (and (stx-pair? stx)
                    (identifier? (stx-car stx))
                    (syntax*->list (stx-cdr stx))
                    (andmap identifier?
                            (syntax*->list (stx-cdr stx)))))
          (raise-syntax-error 'define-pvars "bad syntax" stx)
          (void))
      (let* ([pvars (reverse (syntax*->list (stx-cdr stx)))]
             [unique-at-runtime (map gensym (map syntax-e pvars))]
             [stxquoted-pvars+unique (map (λ (v unique)
                                            `(cons (quote-syntax ,v)
                                                   (quote-syntax ,unique)))
                                          pvars
                                          unique-at-runtime)])
        (datum->syntax
         (quote-syntax here)
         `(begin
            (define-values (,@unique-at-runtime)
              (values ,@(map (λ (pvar) `(gensym (quote ,pvar))) pvars)))
            (define-syntaxes ()
              (begin
                (pop-unreachable-pvars)
                (current-pvars-param
                 (list* ,@stxquoted-pvars+unique
                        (current-pvars-param)))
                (values))))))))]))