suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

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ᵢ.

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-05 08:55:24 +01:00
parent 5e8a21edac
commit 83faf976f1
5 changed files with 177 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
private/ddd.rkt
View File

@ -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))

20
private/lifted-variables-communication.rkt
View File

@ -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)))
(cons lifted-symbol
(syntax-property (x-lifted-pvar-marker lifted-hint-id)
'lifted-pvar
(cons lifted-symbol macro+args-stx)))))

68
private/template-subscripts.rkt
View File

@ -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

36
test/assumption-local-expand-reuse-let-bound-id.rkt Normal file
View File

@ -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))

63
test/test-ddd-top.rkt
View File

@ -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))
'(a a/y b b/y c c/y))