Revert "Fixed incompatibility with Racket 7 which lacks syntax-local-get-shadower"
This reverts commit 250a787151.
This commit is contained in:
Georges Dupéron
parent
250a787151
commit
cecabd982f
|
|
@ -8,43 +8,120 @@
|
|||
(for-syntax '#%kernel
|
||||
racket/private/qq-and-or
|
||||
racket/private/stx))
|
||||
|
||||
;; 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
|
||||
(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)))
|
||||
|
||||
;; (-> any/c (or/c (listof syntax?) #f))
|
||||
(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))))))
|
||||
;; (-> 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)
|
||||
|
|
@ -57,55 +134,36 @@
|
|||
(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))])
|
||||
(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 ()
|
||||
(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))])
|
||||
`(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))))))
|
||||
|
||||
(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)
|
||||
|
|
@ -121,16 +179,16 @@
|
|||
`(cons (quote-syntax ,v)
|
||||
(quote-syntax ,unique)))
|
||||
pvars
|
||||
unique-at-runtime)])
|
||||
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 ()
|
||||
(begin
|
||||
(pop-unreachable-pvars)
|
||||
(current-pvars-param
|
||||
(list* ,@stxquoted-pvars+unique
|
||||
(current-pvars-param)))
|
||||
(values)))))))))
|
||||
(define-syntaxes (,binding)
|
||||
(list* ,@stxquoted-pvars+unique
|
||||
(try-nth-current-pvars ,old-pvars-index)))))))))
|
||||
|
|
@ -1,95 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
;; This is a quick experiment to check that a set of identifiers (syntax
|
||||
;; transformers) can be maintained using a stack, while ensuring that when
|
||||
;; the set is queried at compile-time, only those identifiers which are within
|
||||
;; scope are returned.
|
||||
;;
|
||||
;; It is necessary to understand this in order to internally build a stack of
|
||||
;; definitions of pattern variables, and correctly pop pvars from the stack when
|
||||
;; they go out of scope.
|
||||
|
||||
(require rackunit)
|
||||
|
||||
(define-for-syntax order '())
|
||||
(define-for-syntax (record-order x)
|
||||
(set! order (cons x order)))
|
||||
|
||||
|
||||
(define-for-syntax stack '())
|
||||
(define-for-syntax (push! e)
|
||||
(set! stack (cons e stack)))
|
||||
(define-for-syntax (peek)
|
||||
(car stack))
|
||||
(define-for-syntax (pop!)
|
||||
(set! stack (cdr stack)))
|
||||
(define-for-syntax (pop…!)
|
||||
(when (not (null? stack))
|
||||
(unless (syntax-local-value (car stack) (λ () #f))
|
||||
;(displayln (syntax->datum #`(pop #,(car stack))))
|
||||
(pop!)
|
||||
(pop…!))))
|
||||
|
||||
(define-syntax (def stx)
|
||||
(syntax-case stx ()
|
||||
[(_ var)
|
||||
(begin
|
||||
(pop…!)
|
||||
(push! #'var)
|
||||
#'(define-syntax var 42))]))
|
||||
|
||||
(define-syntax (query stx)
|
||||
(syntax-case stx ()
|
||||
[(_ msg)
|
||||
(begin
|
||||
(pop…!)
|
||||
(record-order (syntax->datum #`(msg . #,stack)))
|
||||
#'(void))]))
|
||||
|
||||
(define (expr x) (void))
|
||||
|
||||
|
||||
(define-syntax (macro stx)
|
||||
#'(def v2))
|
||||
|
||||
(def v1)
|
||||
(macro)
|
||||
(let ()
|
||||
(def v6.1)
|
||||
(query q6.2)
|
||||
(expr (query q6.4))
|
||||
(let ()
|
||||
(def v6.5.1)
|
||||
(void))
|
||||
(let ()
|
||||
(def v6.6.1)
|
||||
;; These queries must *not* contain v6.5.1.
|
||||
(query q6.6.2)
|
||||
(expr (query q6.6.3))
|
||||
(void))
|
||||
(let ()
|
||||
(def v6.7.1)
|
||||
;; These queries must *not* contain v6.5.1 nor v6.6.1.
|
||||
(query q6.7.2)
|
||||
(expr (query q6.7.3))
|
||||
(void))
|
||||
(def v6.3)
|
||||
(void))
|
||||
(query q3)
|
||||
(expr (query q7))
|
||||
(def v4)
|
||||
(query q5)
|
||||
(expr (query q8))
|
||||
|
||||
(check-equal? (let-syntax ([get (λ (stx) #`'#,(reverse order))])
|
||||
get)
|
||||
'((q3 v2 v1)
|
||||
(q5 v4 v2 v1)
|
||||
(q6.2 v6.1 v4 v2 v1)
|
||||
(q6.4 v6.3 v6.1 v4 v2 v1)
|
||||
(q6.6.2 v6.6.1 v6.3 v6.1 v4 v2 v1)
|
||||
(q6.6.3 v6.6.1 v6.3 v6.1 v4 v2 v1)
|
||||
(q6.7.2 v6.7.1 v6.3 v6.1 v4 v2 v1)
|
||||
(q6.7.3 v6.7.1 v6.3 v6.1 v4 v2 v1)
|
||||
(q7 v4 v2 v1)
|
||||
(q8 v4 v2 v1)))
|
||||
|
|
@ -28,61 +28,19 @@
|
|||
(list-ref (current-pvars) (syntax-e #'n)))])
|
||||
(datum->syntax pvar (syntax-e pvar) stx))]))
|
||||
|
||||
|
||||
;; First check that (current-pvars) returns the empty list before anything
|
||||
;; is done:
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
(let ()
|
||||
(define/with-syntax x #'1)
|
||||
(void))
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
;; test that the x is correctly removed, even if no querry was made
|
||||
;; between its creation and the creation of the y.
|
||||
(let () (define/with-syntax x #'1) (void))
|
||||
(let ()
|
||||
(define/with-syntax y #'2)
|
||||
(check-equal? (list-pvars)
|
||||
'(y))
|
||||
(void))
|
||||
|
||||
(check-equal? (list (list-pvars)
|
||||
(syntax-case #'() ()
|
||||
[() (list (list-pvars)
|
||||
(syntax-case #'(1 2 3 a b c) ()
|
||||
[(x y ...)
|
||||
(list-pvars)])
|
||||
(list-pvars))])
|
||||
(list-pvars))
|
||||
'(() (() (y x) ()) ()))
|
||||
|
||||
(check-equal? (list (list-pvars)
|
||||
(syntax-case #'(-1 -2) ()
|
||||
[(k l) (list (list-pvars)
|
||||
(syntax-case #'(1 2 3 a b c) ()
|
||||
[(z t ...)
|
||||
(list-pvars)])
|
||||
(list-pvars))])
|
||||
(list-pvars))
|
||||
'(() ((l k) (t z l k) (l k)) ()))
|
||||
|
||||
;; Simple case:
|
||||
(check-equal? (syntax-parse #'(1 2 3 a b c)
|
||||
[(x y ...)
|
||||
(list-pvars)])
|
||||
'(y x))
|
||||
|
||||
;; Simple case:
|
||||
(check-equal? (syntax-case #'() ()
|
||||
[() (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)
|
||||
|
|
@ -106,9 +64,6 @@
|
|||
(syntax->datum (ref-nth-pvar 3)))))
|
||||
'(4 3 2 1)))
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
||||
;; Tests for syntax-parse
|
||||
(begin
|
||||
(check-equal? (syntax-parse #'(1 2 3 a b c)
|
||||
|
|
@ -414,16 +369,6 @@
|
|||
[_
|
||||
#false]))
|
||||
|
||||
(let ()
|
||||
(define/with-syntax (x ... y) #'(1 2 3))
|
||||
(check-true (match (list-pvars+unique-val)
|
||||
[(list (cons 'y (? symbol?))
|
||||
(cons 'x (? symbol?)))
|
||||
#true]
|
||||
[v
|
||||
(displayln v)
|
||||
#false])))
|
||||
|
||||
(check-true (match (syntax-case #'(1 2 3) ()
|
||||
[(x ... y)
|
||||
(list-pvars+unique-val)])
|
||||
|
|
@ -630,6 +575,3 @@
|
|||
'(() (a) (a b) (a b c) (a b c d) (a b c d e)))
|
||||
|
||||
(check-defs3* 6 65) ;; continue tests with 6 till 65 pvars
|
||||
|
||||
(check-equal? (list-pvars)
|
||||
'())
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
;; This is a quick experiment to see in what order are macros expanded.
|
||||
;;
|
||||
;; It is necessary to understand this in order to internally build a stack of
|
||||
;; definitions of pattern variables, and correctly pop pvars from the stack when
|
||||
;; they go out of scope.
|
||||
|
||||
;; Macros in definition contexts are expanded in a breadth-first order
|
||||
;; Macros in expression contexts are expanded in a breadth-first order
|
||||
;;
|
||||
;; Within a scope (let or top-level), all definitions are expanded,
|
||||
;; then all the expressions
|
||||
|
||||
(require rackunit)
|
||||
|
||||
(define-for-syntax order '())
|
||||
(define-for-syntax (record-order x)
|
||||
(set! order (cons x order)))
|
||||
|
||||
(define-syntax (d stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a)
|
||||
(begin (record-order `(d . ,(syntax-e #'a)))
|
||||
#'(define x 42))]))
|
||||
|
||||
(define-syntax (e stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a)
|
||||
(begin (record-order `(e . ,(syntax-e #'a)))
|
||||
#'42)]))
|
||||
|
||||
(define (expr x) (void))
|
||||
|
||||
(d "+0 012")
|
||||
(expr (e "?3 012"))
|
||||
|
||||
(let ()
|
||||
(d "+4 012_45")
|
||||
(expr (e "?6 012_45"))
|
||||
;; here, we're evaluating an "e" in a definition context,
|
||||
;; therefore it does not know that 5 will exist.
|
||||
(e "¿5 012_4X\"")
|
||||
;; wrapping it with #%expression ensures that it runs after all definitions
|
||||
;; in the current scope (of course it then cannot introduce new definitions).
|
||||
(#%expression (e "e6 012_46\"'"))
|
||||
(let ()
|
||||
(d "+7 012_45_7")
|
||||
(expr (e "?8 012_45_7"))
|
||||
(d "+7 012_45_7'")
|
||||
(expr (e "?8 012_45_7'")))
|
||||
(d "+5 012_45")
|
||||
(expr (e "?9 012_45")))
|
||||
|
||||
(d "+1 012")
|
||||
(expr (e "?A 012"))
|
||||
|
||||
(let ()
|
||||
(d "+B 012_B")
|
||||
(expr (e "?C 012_B")))
|
||||
|
||||
(d "+2 012")
|
||||
(expr (e "?D 012"))
|
||||
(check-equal? (let-syntax ([get (λ (stx) #`'#,(reverse order))])
|
||||
get)
|
||||
'((d . "+0 012")
|
||||
(d . "+1 012")
|
||||
(d . "+2 012")
|
||||
(e . "?3 012")
|
||||
(d . "+4 012_45")
|
||||
(e . "¿5 012_4X\"")
|
||||
(d . "+5 012_45")
|
||||
(e . "?6 012_45")
|
||||
(e . "e6 012_46\"'")
|
||||
(d . "+7 012_45_7")
|
||||
(d . "+7 012_45_7'")
|
||||
(e . "?8 012_45_7")
|
||||
(e . "?8 012_45_7'")
|
||||
(e . "?9 012_45")
|
||||
(e . "?A 012")
|
||||
(d . "+B 012_B")
|
||||
(e . "?C 012_B")
|
||||
(e . "?D 012")))
|
||||
Loading…
Reference in New Issue
Block a user