commit 250a7871513aaa39cb1c4388b9e2c9cfb5425285
parent 43c61290e9874909e230b2d891433d3ebd7bd9cc
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 25 Mar 2018 01:58:17 +0100
Fixed incompatibility with Racket 7 which lacks syntax-local-get-shadower
Diffstat:
4 files changed, 327 insertions(+), 147 deletions(-)
diff --git a/current-pvars.rkt b/current-pvars.rkt
@@ -8,120 +8,43 @@
(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
- ;; (-> any/c (or/c (listof syntax?) #f))
- (define-values (syntax*->list)
- (λ (stxlist)
- (syntax->list (datum->syntax #f stxlist))))
+ (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))
- ;; (-> 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))))
+ (define-values (current-pvars-param)
+ (make-parameter '() current-pvars-param-guard))
- ;; (-> 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))))))
+ (define-values (current-pvars)
+ (lambda ()
+ (pop-unreachable-pvars)
+ (map car (current-pvars-param))))
- ;; (-> 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))))))
+ (define-values (current-pvars+unique)
+ (lambda ()
+ (pop-unreachable-pvars)
+ (current-pvars-param)))
- ;; (-> (listof identifier?))
- (define-values (current-pvars)
- (λ ()
- (map car (try-nth-current-pvars (find-last-current-pvars)))))
+ (define-values (syntax*->list)
+ (λ (stxlist)
+ (syntax->list (datum->syntax #f stxlist))))
- (define-values (current-pvars+unique)
- (λ ()
- (try-nth-current-pvars (find-last-current-pvars)))))
+ (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))))))
;; (with-pvars [pvar ...] . body)
(define-syntaxes (with-pvars)
@@ -134,36 +57,55 @@
(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)])
+ (let* ([pvars (syntax*->list (stx-car (stx-cdr stx)))]
+ [body (stx-cdr (stx-cdr stx))])
(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))))))
+ `(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 …))))
+ ;; (define-pvars pv1 … pvn)
(define-syntaxes (define-pvars)
(lambda (stx)
(if (not (and (stx-pair? stx)
@@ -179,16 +121,16 @@
`(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)))])
+ unique-at-runtime)])
(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)))))))))
-\ No newline at end of file
+ (define-syntaxes ()
+ (begin
+ (pop-unreachable-pvars)
+ (current-pvars-param
+ (list* ,@stxquoted-pvars+unique
+ (current-pvars-param)))
+ (values)))))))))
+\ No newline at end of file
diff --git a/test/test-check-variable-visible.rkt b/test/test-check-variable-visible.rkt
@@ -0,0 +1,95 @@
+#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,19 +28,61 @@
(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)
@@ -64,6 +106,9 @@
(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)
@@ -369,6 +414,16 @@
[_
#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)])
@@ -574,4 +629,7 @@
(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
-\ No newline at end of file
+(check-defs3* 6 65) ;; continue tests with 6 till 65 pvars
+
+(check-equal? (list-pvars)
+ '())
+\ No newline at end of file
diff --git a/test/test-expansion-order.rkt b/test/test-expansion-order.rkt
@@ -0,0 +1,83 @@
+#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
