suzanne.soy/stxparse-info
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Merge Racket ≤ 6.12 and Racket ≥ 7 versions using version-case

Browse Source
This commit is contained in:
Georges Dupéron 2018-03-25 23:49:32 +02:00
parent 472033aa24
commit 025c25338f
2 changed files with 195 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.travis.yml
View File

@ -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:

193
current-pvars.rkt
View File

@ -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)))))))))
(values))))))))]))