commit 025c25338ff96c9275b272cbeabba73a0ef50f4b
parent 472033aa24c4cd686bf697b3431070709fc43db0
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 25 Mar 2018 23:49:32 +0200
Merge Racket ≤ 6.12 and Racket ≥ 7 versions using version-case
Diffstat:
2 files changed, 196 insertions(+), 4 deletions(-)
diff --git a/.travis.yml b/.travis.yml
@@ -31,8 +31,9 @@ env:
###- RACKET_VERSION=6.5 RECENT=true
###- RACKET_VERSION=6.6 RECENT=true
###- RACKET_VERSION=6.7 RECENT=true
- #- RACKET_VERSION=6.12 RECENT=true
- - RACKET_VERSION=HEAD RECENT=true
+ - RACKET_VERSION=6.12 RECENT=true
+ - RACKET_VERSION=RELEASE RECENT=true
+ - RACKET_VERSION=HEAD RECENT=true
matrix:
allow_failures:
diff --git a/current-pvars.rkt b/current-pvars.rkt
@@ -1,4 +1,7 @@
(module current-pvars '#%kernel
+ (#%require version-case
+ (only racket/base version))
+
(#%provide (for-syntax current-pvars
current-pvars+unique)
with-pvars
@@ -8,6 +11,194 @@
(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)
@@ -133,4 +324,4 @@
(current-pvars-param
(list* ,@stxquoted-pvars+unique
(current-pvars-param)))
- (values)))))))))
-\ No newline at end of file
+ (values))))))))]))
+\ No newline at end of file
