Support for define/syntax-parse, including when there are multiple defines. Search for the most up-to-date list of current-pvars is done by performing a dichotomy over a set of sequentially numbered current-pvars-paramNNN. Closes FB case 180.
This commit is contained in:
Georges Dupéron
parent
9a7e7422eb
commit
c42aef881c
|
|
@ -1,24 +1,166 @@
|
|||
#lang racket/base
|
||||
(require racket/stxparam
|
||||
(for-syntax racket/base
|
||||
racket/contract))
|
||||
(module current-pvars '#%kernel
|
||||
(#%provide (for-syntax current-pvars)
|
||||
with-pvars
|
||||
define-pvars)
|
||||
|
||||
(#%require racket/private/small-scheme
|
||||
(for-syntax '#%kernel
|
||||
racket/private/qq-and-or
|
||||
racket/private/stx))
|
||||
|
||||
(provide (for-syntax (rename-out [get-current-pvars current-pvars]))
|
||||
with-pvars)
|
||||
;; 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.
|
||||
|
||||
(define-syntax-parameter current-pvars '())
|
||||
;; 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.
|
||||
|
||||
(define-syntax (with-pvars stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (pvar ...) . body)
|
||||
(andmap identifier? (syntax->list #'(pvar ...)))
|
||||
(with-syntax ([(reverse-pvar ...) (reverse (syntax->list #'(pvar ...)))])
|
||||
#'(syntax-parameterize
|
||||
([current-pvars (list* (quote-syntax reverse-pvar) ...
|
||||
(syntax-parameter-value #'current-pvars))])
|
||||
. body))]))
|
||||
;; (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
|
||||
(define/contract (get-current-pvars)
|
||||
(-> (listof identifier?))
|
||||
(syntax-parameter-value #'current-pvars)))
|
||||
(begin-for-syntax
|
||||
;; (-> 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
|
||||
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)
|
||||
(λ ()
|
||||
(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 (syntax->list (stx-car (stx-cdr stx)))]
|
||||
[quoted-pvars (map (λ (v) `(quote-syntax ,v)) pvars)]
|
||||
[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)))])
|
||||
(datum->syntax
|
||||
(quote-syntax here)
|
||||
`(letrec-syntaxes+values
|
||||
([(,binding) (list* ,@quoted-pvars
|
||||
(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 'with-pvars "bad syntax" stx)
|
||||
(void))
|
||||
(let* ([pvars (syntax->list (stx-cdr stx))]
|
||||
[quoted-pvars (map (λ (v) `(quote-syntax ,v)) pvars)]
|
||||
[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)
|
||||
`(define-syntaxes (,binding)
|
||||
(list* ,@quoted-pvars
|
||||
(try-nth-current-pvars ,old-pvars-index))))))))
|
||||
|
|
@ -139,7 +139,8 @@ residual.rkt.
|
|||
'name 'depth 'syntax?))
|
||||
...
|
||||
(define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
|
||||
...)))]))
|
||||
...
|
||||
(define-pvars name ...))))]))
|
||||
|
||||
(define-syntax-rule (phase-of-enclosing-module)
|
||||
(variable-reference->module-base-phase
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@
|
|||
@racketmodname[syntax/parse]}
|
||||
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
|
||||
|
||||
Source code: @url{https://github.com/jsmaniac/stxparse-info}
|
||||
|
||||
@defmodule[stxparse-info/parse]
|
||||
|
||||
The module @racketmodname[stxparse-info/parse] is a patched version of
|
||||
|
|
|
|||
|
|
@ -4,38 +4,232 @@
|
|||
racket/stxparam
|
||||
rackunit)
|
||||
|
||||
;; Test utilities
|
||||
(define-syntax (list-pvars stx)
|
||||
#`'#,(current-pvars))
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
(check-equal? (syntax-parse #'(1 2 3 a b c)
|
||||
[(x y:nat ... {~parse w (list-pvars)} z ...)
|
||||
(syntax->datum #`[w #,(list-pvars)])])
|
||||
'([y x] [z w y x]))
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
;; Check that the identifier has the right scopes
|
||||
(define-syntax (ref-nth-pvar stx)
|
||||
(syntax-case stx ()
|
||||
[(_ n)
|
||||
(number? (syntax-e #'n))
|
||||
#`#'#,(let ([pvar (list-ref (current-pvars) (syntax-e #'n))])
|
||||
#`#'#,(let ([pvar (if (>= (syntax-e #'n) (length (current-pvars)))
|
||||
#'too-big!
|
||||
(list-ref (current-pvars) (syntax-e #'n)))])
|
||||
(datum->syntax pvar (syntax-e pvar) stx))]))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
(syntax->datum (ref-nth-pvar 0))])
|
||||
1)
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
(cons (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax-parse #'2
|
||||
[x
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1)))]))])
|
||||
'(1 2 1))
|
||||
;; First check that (current-pvars) returns the empty list before anything
|
||||
;; is done:
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
;; Simple case:
|
||||
(check-equal? (syntax-parse #'(1 2 3 a b c)
|
||||
[(x y ...)
|
||||
(list-pvars)])
|
||||
'(y x))
|
||||
|
||||
;; Mixed definitions from user code and from a macro
|
||||
(begin
|
||||
(define-syntax (mixed stx)
|
||||
(syntax-case stx ()
|
||||
[(_ val def body)
|
||||
#'(let ()
|
||||
(define/syntax-parse x #'val)
|
||||
def
|
||||
body)]))
|
||||
|
||||
(check-equal? (mixed 1 (define/syntax-parse y #'2)
|
||||
(mixed 3 (define/syntax-parse y #'4)
|
||||
(list-pvars)))
|
||||
'(y x y x))
|
||||
|
||||
(check-equal? (mixed 1 (define/syntax-parse y #'2)
|
||||
(mixed 3 (define/syntax-parse y #'4)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2))
|
||||
(syntax->datum (ref-nth-pvar 3)))))
|
||||
'(4 3 2 1)))
|
||||
|
||||
;; Tests for syntax-parse
|
||||
(begin
|
||||
(check-equal? (syntax-parse #'(1 2 3 a b c)
|
||||
[(x y:nat ... {~parse w (list-pvars)} z ...)
|
||||
(syntax->datum #`[w #,(list-pvars)])])
|
||||
'([y x] [z w y x]))
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
(syntax->datum (ref-nth-pvar 0))])
|
||||
1)
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
(cons (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax-parse #'2
|
||||
[x
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1)))]))])
|
||||
'(1 2 1)))
|
||||
|
||||
;; tests for define/syntax-parse
|
||||
(begin
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse z #'3)
|
||||
(list-pvars)])
|
||||
'(z y x))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse z #'3)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2)))])
|
||||
'(3 2 1))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse x #'3)
|
||||
(list-pvars)])
|
||||
'(x y x))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse x #'3)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2)))])
|
||||
'(3 2 1))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse x #'3)
|
||||
(define/syntax-parse y #'4)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2))
|
||||
(syntax->datum (ref-nth-pvar 3)))])
|
||||
'(4 3 2 1))
|
||||
|
||||
(check-equal? (syntax-parse #'1
|
||||
[x
|
||||
#:with y #'2
|
||||
(define/syntax-parse x #'3)
|
||||
(define/syntax-parse y #'4)
|
||||
(define/syntax-parse z #'5)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2))
|
||||
(syntax->datum (ref-nth-pvar 3))
|
||||
(syntax->datum (ref-nth-pvar 4)))])
|
||||
'(5 4 3 2 1))
|
||||
|
||||
(check-equal? (syntax-parse #'(1 2 3)
|
||||
[(x y z)
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'5)
|
||||
(list (syntax->datum (ref-nth-pvar 0))
|
||||
(syntax->datum (ref-nth-pvar 1))
|
||||
(syntax->datum (ref-nth-pvar 2))
|
||||
(syntax->datum (ref-nth-pvar 3))
|
||||
(syntax->datum (ref-nth-pvar 4)))])
|
||||
'(5 4 3 2 1))
|
||||
|
||||
(check-equal? (syntax-parse #'(1 2 3)
|
||||
[(x y z)
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'5)
|
||||
(list-pvars)])
|
||||
'(y x z y x))
|
||||
|
||||
;; Test with nested let, less variables in the nested let
|
||||
(check-equal? (let ()
|
||||
(define/syntax-parse w #'1)
|
||||
(define/syntax-parse x #'2)
|
||||
(define/syntax-parse y #'3)
|
||||
(define/syntax-parse z #'4)
|
||||
(list (list-pvars)
|
||||
(let ()
|
||||
(define/syntax-parse w #'5)
|
||||
(define/syntax-parse x #'6)
|
||||
(list-pvars))
|
||||
(list-pvars)))
|
||||
'((z y x w) (x w z y x w) (z y x w)))
|
||||
|
||||
;; Test with nested let, more variables in the nested let
|
||||
(check-equal? (let ()
|
||||
(define/syntax-parse w #'1)
|
||||
(define/syntax-parse x #'2)
|
||||
(list (list-pvars)
|
||||
(let ()
|
||||
(define/syntax-parse w #'3)
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'5)
|
||||
(define/syntax-parse z #'6)
|
||||
(list-pvars))
|
||||
(list-pvars)))
|
||||
'((x w) (z y x w x w) (x w)))
|
||||
|
||||
(check-equal? (let ()
|
||||
(define/syntax-parse w #'1)
|
||||
(define/syntax-parse x #'2)
|
||||
(define/syntax-parse y #'3)
|
||||
(define/syntax-parse z #'4)
|
||||
(list (list-pvars)
|
||||
(syntax-parse #'5
|
||||
[k
|
||||
(define/syntax-parse w #'5)
|
||||
(define/syntax-parse x #'6)
|
||||
(list-pvars)])
|
||||
(list-pvars)))
|
||||
'((z y x w) (x w k z y x w) (z y x w)))
|
||||
|
||||
(check-equal? (let ()
|
||||
(define/syntax-parse w #'1)
|
||||
(define/syntax-parse x #'2)
|
||||
(list (list-pvars)
|
||||
(syntax-parse #'5
|
||||
[k
|
||||
(define/syntax-parse w #'3)
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'5)
|
||||
(define/syntax-parse z #'6)
|
||||
(list-pvars)])
|
||||
(list-pvars)))
|
||||
'((x w) (z y x w k x w) (x w)))
|
||||
|
||||
(check-equal? (let ()
|
||||
(define/syntax-parse w #'1)
|
||||
(define/syntax-parse x #'2)
|
||||
(list (list-pvars)
|
||||
(syntax-parse #'5
|
||||
[k
|
||||
(define/syntax-parse w #'3)
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'5)
|
||||
(define/syntax-parse z #'6)
|
||||
(list (list-pvars)
|
||||
(syntax-parse #'5
|
||||
[k
|
||||
(define/syntax-parse x #'4)
|
||||
(define/syntax-parse y #'4)
|
||||
(list-pvars)])
|
||||
(list-pvars))])
|
||||
(list-pvars)))
|
||||
'((x w)
|
||||
((z y x w k x w)
|
||||
(y x k z y x w k x w)
|
||||
(z y x w k x w))
|
||||
(x w))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user