commit cecabd982f99f0aab8dbd4c1d85885f34e9a389c
parent 250a7871513aaa39cb1c4388b9e2c9cfb5425285
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 25 Mar 2018 20:44:50 +0200
Revert "Fixed incompatibility with Racket 7 which lacks syntax-local-get-shadower"
This reverts commit 250a7871513aaa39cb1c4388b9e2c9cfb5425285.
Diffstat:
4 files changed, 147 insertions(+), 327 deletions(-)
diff --git a/current-pvars.rkt b/current-pvars.rkt
@@ -8,43 +8,120 @@
(for-syntax '#%kernel
racket/private/qq-and-or
racket/private/stx))
- (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)))
+ ;; 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))))
+
- (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))))))
+ ;; (-> 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))])
-
- (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 …))))
+ `(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-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)))))))))
-\ No newline at end of file
+ (define-syntaxes (,binding)
+ (list* ,@stxquoted-pvars+unique
+ (try-nth-current-pvars ,old-pvars-index)))))))))
+\ No newline at end of file
diff --git a/test/test-check-variable-visible.rkt b/test/test-check-variable-visible.rkt
@@ -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)))
-\ No newline at end of file
diff --git a/test/test-current-pvars.rkt b/test/test-current-pvars.rkt
@@ -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)])
@@ -629,7 +574,4 @@
(check-equal? (expected-defs3 a b c d e)
'(() (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)
- '())
-\ No newline at end of file
+(check-defs3* 6 65) ;; continue tests with 6 till 65 pvars
+\ No newline at end of file
diff --git a/test/test-expansion-order.rkt b/test/test-expansion-order.rkt
@@ -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")))
-\ No newline at end of file
