commit c42aef881cf49d4cd56506af45a15954fa6939a1
parent 9a7e7422eb6d1d953c1804e116b957fc8d207baf
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Mon, 23 Jan 2017 16:51:14 +0100
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.
Diffstat:
4 files changed, 390 insertions(+), 52 deletions(-)
diff --git a/current-pvars.rkt b/current-pvars.rkt
@@ -1,24 +1,166 @@
-#lang racket/base
-(require racket/stxparam
- (for-syntax racket/base
- racket/contract))
-
-(provide (for-syntax (rename-out [get-current-pvars current-pvars]))
- with-pvars)
-
-(define-syntax-parameter current-pvars '())
-
-(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))]))
-
-(begin-for-syntax
- (define/contract (get-current-pvars)
- (-> (listof identifier?))
- (syntax-parameter-value #'current-pvars)))
-\ No newline at end of file
+(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))
+
+ ;; 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
+ ;; (-> 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))))))))
+\ No newline at end of file
diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt
@@ -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
diff --git a/scribblings/stxparse-info.scrbl b/scribblings/stxparse-info.scrbl
@@ -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
diff --git a/test/test-current-pvars.rkt b/test/test-current-pvars.rkt
@@ -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))
-\ No newline at end of file
+
+;; 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))))
