commit 83faf976f13c3cb0b85832440fe9ca1714cc5594
parent 5e8a21edac3117ac0aa23855bdb3d5e3c23edff8
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 5 Feb 2017 08:55:24 +0100
Fixes bug: (ddd #'yᵢ) used to generate different ids each time, because the value of yᵢ was attached to the shadowed xᵢ, not to the “main” xᵢ.
Diffstat:
5 files changed, 179 insertions(+), 42 deletions(-)
diff --git a/private/ddd.rkt b/private/ddd.rkt
@@ -22,7 +22,6 @@
(define-for-syntax x-pvar-scope (make-syntax-introducer))
(define-for-syntax x-pvar-present-marker (make-syntax-introducer))
-(define-for-syntax x-lifted-pvar-marker (make-syntax-introducer))
(begin-for-syntax
(define/contract (attribute-real-valvar attr)
@@ -135,11 +134,13 @@
(define lifted-variables
(map (λ (id)
(define prop (syntax-property id 'lifted-pvar))
- (unless ((cons/c symbol? syntax?) prop)
+ (unless ((cons/c symbol? stx-list?) prop)
+ (displayln id)
+ (displayln prop)
(raise-syntax-error 'ddd
(string-append
- "internal error: 'lifted-pvar property was"
- " missing or not a (cons/c symbol? syntax?).")
+ "internal error: 'lifted-pvar property was "
+ "missing or not a (cons/c symbol? stx-list?)")
stx))
prop)
(filter (λ (id) (all-scopes-in? x-lifted-pvar-marker id))
@@ -262,9 +263,10 @@
(define-values (present-variables lifted-variables)
(extract-present-variables #'expanded-f stx))
- (displayln lifted-variables)
+ (define/with-syntax ([lifted-key lifted-macro+args …] …) lifted-variables)
- (unless (ormap identity present-variables)
+ (unless (or (ormap identity present-variables)
+ (not (null? lifted-variables)))
(raise-syntax-error 'ddd
"no pattern variables were found in the body"
stx))
@@ -286,7 +288,8 @@
(define/with-syntax ((_ iterated-pvar iterated-pvarᵢ _ _) …)
(filter car present?+pvars))
- (when (stx-null? #'(iterated-pvar …))
+ (when (and (stx-null? #'(iterated-pvar …))
+ (null? lifted-variables))
(no-pvar-to-iterate-error present?+pvars))
;; If the pvar is iterated, use the iterated pvarᵢ
@@ -297,12 +300,13 @@
[(list #f pv pvᵢ #f _) #'#f])
present?+pvars)))
- #'(map#f* (λ (iterated-pvarᵢ …)
- (expanded-f filling-pvar … #false)) ;; TODO: the lifted pvars here …………………………………………
- (list (quote-syntax iterated-pvar)
- …)
- (list (attribute* iterated-pvar)
- …)))
+ #'(map#f* (λ (iterated-pvarᵢ … lifted-key …)
+ (expanded-f filling-pvar …
+ (make-hash (list (cons 'lifted-key lifted-key) …))))
+ (list (quote-syntax iterated-pvar) …
+ (quote-syntax lifted-key) …) ;; TODO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! not the real variable
+ (list (attribute* iterated-pvar) …
+ (lifted-macro+args … 1 #;depth?????????????????????????????????????????????????) …)))
(define-syntax/case (shadow pvar new-value) ()
(match (attribute-info #'pvar '(pvar attr))
diff --git a/private/lifted-variables-communication.rkt b/private/lifted-variables-communication.rkt
@@ -1,7 +1,9 @@
#lang racket/base
(provide lift-late-pvars-param
- (for-syntax lift-late-pvars-target))
+ (for-syntax lift-late-pvars-target
+ lifted-pvar
+ x-lifted-pvar-marker))
(require racket/stxparam
(for-syntax racket/base
@@ -11,16 +13,18 @@
(define-syntax-parameter lift-late-pvars-param #f)
(define-for-syntax (lift-late-pvars-target)
- (syntax-parameter-value #'must-lift-late-pvars?-param))
+ (syntax-parameter-value #'lift-late-pvars-param))
+
+(define-for-syntax x-lifted-pvar-marker (make-syntax-introducer))
;; Returns two values, the syntax to insert, and a symbol to use at run-time
;; to access the value of that lifted pvar.
(begin-for-syntax
- (define/contract (lifted-pvar name expr-stx)
- (-> symbol? syntax? (values symbol? syntax?))
+ (define/contract (lifted-pvar name macro+args-stx)
+ (-> symbol? syntax? (cons/c symbol? syntax?))
(define lifted-symbol (gensym (format "lifted-~a" name)))
(define lifted-hint-id (generate-temporary lifted-symbol))
- (values (syntax-property lifted-hint-id
- 'late-pvar
- (cons lifted-symbol expr-stx))
- lifted-symbol)))
-\ No newline at end of file
+ (cons lifted-symbol
+ (syntax-property (x-lifted-pvar-marker lifted-hint-id)
+ 'lifted-pvar
+ (cons lifted-symbol macro+args-stx)))))
+\ No newline at end of file
diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt
@@ -82,7 +82,7 @@
(true?
(and (list? l*)
(if (and same-shape (> depth 0))
- (or (andmap false? l*) ;; all #f
+ (or (andmap false? l*) ;; all #f
(andmap identity l*)) ;; all non-#f
#t)
(let ([l* (filter identity l*)])
@@ -114,10 +114,7 @@
(sub1 depth)))
l*)))))
-(define-for-syntax (sub*template self-form tmpl-form)
- (sub*template-impl self-form tmpl-form))
-
-(define-for-syntax (sub*template-impl self-form tmpl-form)
+(define-for-syntax (sub*template self-form tmpl-form get-attribute*)
(syntax-parser
[(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}}
{~optkw #:props (prop:id ...)}
@@ -181,21 +178,53 @@
(define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate))
- #`(let-values ()
- (define-values (whole-form-id) (quote-syntax #,this-syntax))
- (derive
- bound (binder …) unique-at-runtime-ids ellipsis-depth whole-form-id)
- …
- (let-values ()
- ;; check that all the binders for a given bound are compatible.
- ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) …
- ;; actually call template or quasitemplate
- #,result))]))
+ (define lift-target (lift-late-pvars-target))
+ (if lift-target
+ (let ()
+ (define/with-syntax ([token . to-insert] …)
+ (stx-map lifted-pvar
+ (stx-map syntax-e #'(bound …)) ;; name
+ #`([lifted-var-macro bound] …)))
+ #`(let-values ()
+ (quote-syntax (to-insert …))
+ (copy-raw-syntax-attribute bound
+ (hash-ref #,lift-target 'token)
+ ellipsis-depth
+ #t)
+ …
+ #,(if get-attribute*
+ #'(list (attribute* bound ) …)
+ result)))
+ #`(let-values ()
+ (define-values (whole-form-id) (quote-syntax #,this-syntax))
+ (derive bound
+ (binder …)
+ unique-at-runtime-ids
+ ellipsis-depth
+ whole-form-id)
+ …
+ #,(if get-attribute*
+ #'(list (attribute* bound ) …)
+ #`(let-values ()
+ ;; check that all the binders for a given bound are
+ ;; compatible.
+ ((ellipsis-count/c ellipsis-depth)
+ (list (attribute* binder) …))
+ …
+ ;; actually call template or quasitemplate
+ #,result))))]))
+
+(define-syntax (lifted-var-macro stx)
+ (syntax-case stx ()
+ [(_ bound depth)
+ #`(car (subtemplate/attribute* bound))]))
+(define-syntax subtemplate/attribute*
+ (sub*template 'subtemplate #'template #t))
(define-syntax subtemplate
- (sub*template 'subtemplate #'template))
+ (sub*template 'subtemplate #'template #f))
(define-syntax quasisubtemplate
- (sub*template 'quasisubtemplate #'quasitemplate))
+ (sub*template 'quasisubtemplate #'quasitemplate #f))
(define/contract (multi-hash-ref! h keys)
;; This assumes that the hash does not get mutated during the execution of
@@ -341,7 +370,10 @@
(quote-syntax whole-form-id)
(quote-syntax bound))
- (copy-raw-syntax-attribute bound temp-cached ellipsis-depth #t))))
+ (copy-raw-syntax-attribute bound
+ temp-cached
+ ellipsis-depth
+ #t))))
(define (check-derived-ellipsis-shape ellipsis-depth
temp-generated
diff --git a/test/assumption-local-expand-reuse-let-bound-id.rkt b/test/assumption-local-expand-reuse-let-bound-id.rkt
@@ -0,0 +1,36 @@
+#lang racket
+(require (for-syntax racket/syntax))
+;; x is first bound with a let inside the local-expanded code.
+;; The identifier is extracted (presumably with that let's scope,
+;; and re-uesd as a definition outside of the let.
+;; Check that this is okay (no "ambiguous identifier" or "identifier
+;; used out of context" error.
+(define-syntax (test stx)
+ (syntax-case stx ()
+ [(_ e)
+ (let ()
+ (define/with-syntax whole
+ (local-expand #'(let-values ([(e) 2]) e) 'expression '()))
+ (define/with-syntax (_ _ xx) #'whole)
+ #'(let-values ()
+ (define xx 3)
+ (list xx
+ whole)))]))
+
+(let ([x 1])
+ (test x))
+
+(define-syntax (test2 stx)
+ (syntax-case stx ()
+ [(_ e)
+ (let ()
+ (define/with-syntax whole
+ (local-expand #'(let-values ([(e) 2]) e) 'expression '()))
+ (define/with-syntax (_ _ xx) #'whole)
+ #'(let-values ([(xx) xx])
+ (list xx
+ whole)))]))
+
+;; This does produce an error. The xxx must not be used as an expression.
+#;(let ([x 1])
+ (test2 x))
+\ No newline at end of file
diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt
@@ -2,6 +2,7 @@
(require subtemplate/private/top-subscripts
subtemplate/private/ddd-forms
+ (only-in subtemplate/private/ddd ddd)
(except-in subtemplate/private/override ?? ?@)
stxparse-info/case
stxparse-info/parse
@@ -41,6 +42,66 @@
(list #'yᵢ …)]))
'(a/y b/y c/y))
+(check-match (syntax-case #'([a b c] [d e]) ()
+ [((xᵢ …) …)
+ (list (list #'yᵢ …) …)])
+ (list (list (? syntax?) (? syntax?) (? syntax?))
+ (list (? syntax?) (? syntax?))))
+
+(check-equal? (map (curry map syntax->datum)
+ (syntax-case #'([a b c] [d e]) ()
+ [((xᵢ …) …)
+ (list (list #'yᵢ …) …)]))
+ '([a/y b/y c/y] [d/y e/y]))
+
+(check-match (syntax-case #'([(a1 a2) (b1) (c1 c2 c3)]
+ [(d1 d2 d3 d4) (e1 e2 e3 e4 e5)]) ()
+ [(((xᵢ …) …) …)
+ (list (list (list #'yᵢ …) …) …)])
+ (list (list (list (? syntax?) (? syntax?))
+ (list (? syntax?))
+ (list (? syntax?) (? syntax?) (? syntax?)))
+ (list (list (? syntax?) (? syntax?) (? syntax?) (? syntax?))
+ (list (? syntax?) (? syntax?) (? syntax?)
+ (? syntax?) (? syntax?)))))
+
+(check-equal? (map (curry map (curry map syntax->datum))
+ (syntax-case #'([(a1 a2) (b1) (c1 c2 c3)]
+ [(d1 d2 d3 d4) (e1 e2 e3 e4 e5)]) ()
+ [(((xᵢ …) …) …)
+ (list (list (list #'yᵢ …) …) …)]))
+ '([(a1/y a2/y) (b1/y) (c1/y c2/y c3/y)]
+ [(d1/y d2/y d3/y d4/y) (e1/y e2/y e3/y e4/y e5/y)]))
+
+;; CHeck that the same ids are produced.
+(check-true (let ([ids (flatten
+ (syntax-case #'(id) ()
+ [(_aᵢ …)
+ (list
+ (ddd #'bᵢ)
+ (list #'bᵢ …)
+ (syntax->list #'(bᵢ …)))]))])
+ (andmap (curry apply free-identifier=?)
+ (cartesian-product ids ids))))
+
+(check-true (let ([ids (flatten
+ (syntax-case #'((id)) ()
+ [((aᵢ …) …)
+ (list
+ (ddd (ddd #'bᵢ))
+ (list (list #'bᵢ …) …)
+ (stx-map syntax->list #'((bᵢ …) …))
+ (syntax->list #'(bᵢ … …))
+ (map syntax->list (list #'(bᵢ …) …)))]))])
+ (andmap (curry apply free-identifier=?)
+ (cartesian-product ids ids))))
+
+(check-equal? (map (curry map syntax->datum)
+ (syntax-case #'([a b c] [d e]) ()
+ [((xᵢ …) …)
+ (list (list #'yᵢ …) …)]))
+ '([a/y b/y c/y] [d/y e/y]))
+
(check-match (syntax-case #'(a b c) ()
[(xᵢ …)
([list xᵢ #'yᵢ] …)])
@@ -81,4 +142,4 @@
(syntax-case #'(a b c) ()
[(xᵢ …)
({?@ #'xᵢ #'yᵢ} …)])))
- '(a a/y b b/y c c/y))
-\ No newline at end of file
+ '(a a/y b b/y c c/y))
