327 lines
14 KiB
Racket
327 lines
14 KiB
Racket
(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))))))))])) |