commit 6921eb0e673673a6581861cec435fa24b9de5228
parent 29bf4ef88aa0eac987bec4bdf0e2ef788d0a191e
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 6 Oct 2016 16:56:19 +0200
Hopefully fixed scope issues with subtemplate
Diffstat:
2 files changed, 120 insertions(+), 175 deletions(-)
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -13,63 +13,62 @@
phc-toolkit/untyped
syntax/strip-context
srfi/13
+ syntax/contract
racket/contract))
(provide (rename-out [new-syntax-parse syntax-parse]
[new-syntax-case syntax-case])
subtemplate
- quasisubtemplate
- (for-syntax find-subscript-binder)) ;; for testing only
+ quasisubtemplate)
(begin-for-syntax (struct derived ()))
(define-syntax-parameter maybe-syntax-pattern-variable-ids '())
-(define empty-pvar-values #f)
+(define empty-pvar-values '())
(define-syntax-parameter pvar-values-id (make-rename-transformer
#'empty-pvar-values))
+(define-for-syntax (new-scope rest lctx)
+ ;(wrap-expr/c
+ ;#'(listof (cons/c identifier? (listof symbol?)))
+ #`(cons (cons (quote-syntax #,(syntax-local-get-shadower
+ (datum->syntax lctx
+ 'outer-lctx))
+ #:local)
+ '#,(~> (syntax->datum rest)
+ flatten
+ (filter symbol? _)
+ (remove-duplicates)))
+ (syntax-parameter-value
+ #'maybe-syntax-pattern-variable-ids)));)
+
(define-syntax/parse (new-syntax-parse . rest)
(quasisyntax/top-loc (stx-car stx)
- ;; HERE insert a hash table, to cache the uses
- ;; lifting the define-temp-ids is not likely to work, as they
+ ;; HERE insert a hash table, to cache the uses of derived pvars.
+ ;; Lifting the define-temp-ids is not likely to work, as they
;; need to define syntax pattern variables so that other macros
;; can recognize them. Instead, we only lift the values, but still
;; do the bindings around the subtemplate.
- (let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
- ;; TODO: add a let before calling get-shadower.
+ (let ([the-pvar-values (cons (make-hash) pvar-values-id)])
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
- ((λ (x) #;(displayln x) x)
- (cons (syntax->list
- (quote-syntax
- #,(~> (syntax->datum #'rest)
- flatten
- (filter symbol? _)
- (remove-duplicates)
- (map (λ (sym)
- (syntax-local-get-shadower
- (datum->syntax (stx-car stx)
- sym)
- #t))
- _))
- #:local))
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids)))]
+ #,(new-scope #'rest (stx-car stx))]
[pvar-values-id (make-rename-transformer
#'the-pvar-values)])
(syntax-parse . rest)))))
(define-syntax/case (new-syntax-case . rest) ()
- (quasisyntax/top-loc (stx-car stx)
- (let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
- (syntax-parameterize ([maybe-syntax-pattern-variable-ids
- (cons '#,(remove-duplicates
- (filter symbol?
- (flatten
- (syntax->datum #'rest))))
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids))]
- [pvar-values-id (make-rename-transformer
- #'the-pvar-values)])
- (syntax-case . rest)))))
+ (error "new-syntax-case not implemented yet")
+ #;(quasisyntax/top-loc (stx-car stx)
+ (let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
+ (syntax-parameterize ([maybe-syntax-pattern-variable-ids
+ (cons '#,(remove-duplicates
+ (filter symbol?
+ (flatten
+ (syntax->datum #'rest))))
+ (syntax-parameter-value
+ #'maybe-syntax-pattern-variable-ids))]
+ [pvar-values-id (make-rename-transformer
+ #'the-pvar-values)])
+ (syntax-case . rest)))))
(begin-for-syntax
(define/contract (string-suffix a b)
@@ -99,55 +98,75 @@
(let* ([binder-subscripts (extract-subscripts binder)]
[bound-subscripts (extract-subscripts bound)])
(and (string=? binder-subscripts bound-subscripts)
+ (not (string=? binder-subscripts ""))
binder-subscripts)))
- (define/contract (derived? binder)
- (-> identifier? boolean?)
- (displayln 'TODO-89641)
- #f)
-
- (define/contract (find-subscript-binder2a scopes bound)
- (-> (listof (listof identifier?))
+ (define/contract (find-subscript-binder2a lctx scopes bound scope-depth)
+ (-> identifier?
+ (listof (cons/c identifier? (listof symbol?)))
identifier?
- (listof identifier?))
+ exact-nonnegative-integer?
+ (listof (list/c identifier? exact-nonnegative-integer?)))
(if (null? scopes)
'()
(let ()
- (define scope (car scopes))
- (define recur-found (find-subscript-binder2a (cdr scopes) bound))
+ (define outer-lctx (caar scopes))
+ (define syms (cdar scopes))
+ (define recur-found (find-subscript-binder2a outer-lctx
+ (cdr scopes)
+ bound
+ (add1 scope-depth)))
(define found-here
- (for*/list ([binder (in-list scope)]
- #:when (displayln (list (syntax-e bound) (syntax-e binder)
- 'pvar?= (syntax-pattern-variable?
- (syntax-local-value (replace-context bound binder)
- (thunk #f)))
- 'derived= (not (derived? binder))
- 'subscripts= (subscript-equal? bound
- binder)))
+ (for*/list ([binder-sym (in-list syms)]
+ [binder (in-value (datum->syntax lctx binder-sym))]
+ #;#:when #;(displayln (list bound binder
+ 'pvar?= (syntax-pattern-variable?
+ (syntax-local-value binder (thunk #f)))
+ 'derived?= (derived?
+ (syntax-local-value
+ (format-id binder
+ " is-derived-~a "
+ binder)
+ (thunk #f)))
+ (subscript-equal? bound
+ binder)))
#:when (syntax-pattern-variable?
- (syntax-local-value (replace-context bound binder) ;; why do I need replace-context here???
- (thunk #f)))
- #:when (not (derived? binder))
+ (syntax-local-value binder (thunk #f)))
+ #:when (not (derived?
+ (syntax-local-value
+ (format-id binder
+ " is-derived-~a "
+ binder)
+ (thunk #f))))
[subscripts (in-value (subscript-equal? bound
binder))]
#:when subscripts)
- binder))
+ ;(displayln (list binder scope-depth))
+ (list binder scope-depth)))
+ ;(displayln (list* 'found-here= bound '→ found-here))
(if (null? found-here)
recur-found
(append found-here recur-found)))))
(define/contract (find-subscript-binder2 bound)
(-> identifier?
- (or/c #f (list/c (syntax/c (listof identifier?))
- exact-nonnegative-integer?
- syntax?)))
+ (or/c #f (list/c identifier? ;; bound
+ (syntax/c (listof identifier?)) ;; bindings
+ exact-nonnegative-integer? ;; ellipsis-depth
+ exact-nonnegative-integer? ;; scope-depth
+ syntax?))) ;; check-ellipsis-count
(define scopes (syntax-parameter-value #'maybe-syntax-pattern-variable-ids))
- (define/with-syntax (binder …) (find-subscript-binder2a scopes bound))
+ (define/with-syntax ([binder scope-depth] …)
+ (find-subscript-binder2a bound ;; TODO: check this is okay (should be).
+ scopes
+ bound
+ 0))
+ ;(displayln (syntax->datum #`(2 bound= #,bound 2a-result= [binder scope-depth] …)))
(if (stx-null? #'(binder …))
#f
(let ()
(define depths
- (stx-map (∘ syntax-mapping-depth syntax-local-value) (replace-context bound #'(binder …)))) ;; why do I need replace-context here???
+ (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
(unless (or (< (length depths) 2) (apply = depths))
(raise-syntax-error 'subtemplate
(format "inconsistent depths: ~a"
@@ -157,47 +176,11 @@
;; ellipsis count
(define/with-syntax check-ellipsis-count-ddd
(nest-ellipses #'(binder …) (car depths)))
- (list #'(binder …) (car depths) #'check-ellipsis-count-ddd))))
-
- (define/contract (find-subscript-binder bound [fallback bound])
- (->* (identifier?) (any/c) (or/c identifier? any/c))
- (define result/scopes
- (for/list ([scope (in-list
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids))]
- [scope-depth (in-naturals)])
- (define result
- (for*/list ([binder (in-list scope)]
- #:when (displayln (list 'bound= (syntax-e bound)
- 'binder= (syntax-e binder)
- 'patvar? (syntax-pattern-variable? (syntax-local-value binder (thunk #f)))
- 'free=?/shadowed
- (free-identifier=? binder
- (replace-context bound binder))))
- #:unless (string=? (identifier->string binder)
- (identifier->string bound))
- [subscripts (in-value (subscript-binder? bound
- binder))]
- #:when subscripts)
- (displayln (list 'bound= (syntax-e bound)
- 'binder= (syntax-e binder)
- 'patvar? (syntax-pattern-variable? (syntax-local-value binder (thunk #f)))
- 'free=?/shadowed
- (free-identifier=? binder
- (replace-context bound binder))
- subscripts))
- (cons binder subscripts)))
- (and (not (null? result))
- (syntax-local-introduce
- (car (argmax (∘ string-length cdr) result))))))
- (displayln (list* (syntax-e bound)
- (map stx-e result/scopes)
- (stx-e (ormap identity result/scopes))
- (map (λ (v) (map syntax-e v))
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids))))
- (or (ormap identity result/scopes)
- fallback))
+ (list bound
+ #'(binder …)
+ (car depths)
+ (apply max (syntax->datum #'(scope-depth …)))
+ #'check-ellipsis-count-ddd))))
(define/contract (nest-ellipses stx n)
(-> syntax? exact-nonnegative-integer? syntax?)
@@ -206,43 +189,6 @@
#`(#,(nest-ellipses stx (sub1 n))
(… …)))))
-(define-syntax/case (derive bound binder stx-depth) ()
- (define/with-syntax bound-def (replace-context #'binder #'bound))
- (define depth (syntax-e #'stx-depth))
- (define/with-syntax bound-ddd (nest-ellipses #'bound-def depth))
- (define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound-def))
- (define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
- (syntax-e #'tmp-id))))
- (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
- (define/with-syntax binder-ddd (nest-ellipses #'binder depth))
- ;; HERE: cache the define-temp-ids in the free-id-table, and make sure
- ;; that we retrieve the cached ones, so that two subtemplate within the same
- ;; syntax-case or syntax-parse clause use the same derived ids.
- ;; TODO: mark specially those bindings bound by (derive …) so that they are
- ;; not seen as original bindings in nested subtemplates (e.g. with an
- ;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
- ;; (syntax-parse #'(a b c)
- ;; [(xᵢ …)
- ;; (quasisubtemplate (yᵢ …
- ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
- ;; zᵢ …))])
- ;; the test above is not exactly right (zᵢ will still have the correct
- ;; binding), but it gives the general idea.
-
- ;; TODO: shouldn't be called in the first place?
- (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
- #'(begin)
- ((λ (x)
- #;(newline)
- ;(displayln (syntax->datum x))
- ;(displayln (list #'bound-def #'binder (hash-ref (syntax-debug-info #'bound-def) 'context)))
- x)
- #`(begin (define-temp-ids tmp-str binder-ddd)
- (define cached (free-id-table-ref! pvar-values-id
- (quote-syntax bound-def #:local)
- #'tmp-ddd))
- (define/with-syntax bound-ddd cached)))))
-
(define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
(define acc '())
(define (fold-process stx rec)
@@ -253,16 +199,9 @@
[id (identifier? #'id)
(let ([binders (find-subscript-binder2 #'id)])
(when binders
- (displayln (syntax->datum (datum->syntax #f (cons #'id binders))))
- (set! acc (cons (cons #'id binders)
- acc)))
- #'id)
- #;(let ([binder (find-subscript-binder #'id #f)])
- (when binder
- (let ([depth (syntax-mapping-depth
- (syntax-local-value binder))])
- (set! acc `((,#'id ,binder ,depth) . ,acc))))
- #'id)]
+ ;(displayln (syntax->datum (datum->syntax #f binders)))
+ (set! acc (cons binders acc)))
+ #'id)]
[other (rec #'other)]))
(define result
(quasisyntax/top-loc #'self
@@ -271,22 +210,22 @@
#'tmpl))))
;; Make sure that we remove duplicates, otherwise we'll get errors if we
;; define the same derived id twice.
- (define/with-syntax ([bound (binder0 . binders) depth check-ellipsis-count] …)
- (remove-duplicates acc free-identifier=? #:key car))
- #;(define/with-syntax ([bound binder depth] …)
- (remove-duplicates acc free-identifier=? #:key car))
+ (define/with-syntax ([bound (binder0 . binders)
+ depth
+ scope-depth
+ check-ellipsis-count] …)
+ (remove-duplicates acc #:key car))
- (displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth)
- …)))
+ #;(displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth scope-depth)
+ …)))
#`(let ()
- #;(derive bound binder depth)
- (derive2 bound binder0 (binder0 . binders) depth)
+ (derive2 bound binder0 (binder0 . binders) depth scope-depth)
…
(let ()
- #'#,(replace-context ;; TODO: this is most certainly wrong
- (stx-car #'(bound …))
- #'(check-ellipsis-count …))
+ ;; no-op, just to raise an error when they are incompatible
+ #'(check-ellipsis-count …)
+ ;; actually call template or quasitemplate
#,result)))
(define-syntax subtemplate (sub*template #'template))
@@ -296,7 +235,7 @@
-(define-syntax/case (derive2 bound binder0 binders stx-depth) ()
+(define-syntax/case (derive2 bound binder0 binders stx-depth stx-scope-depth) ()
(define/with-syntax bound-def #'bound #;(replace-context #'binder0 #'bound))
(define depth (syntax-e #'stx-depth))
(define/with-syntax bound-ddd (nest-ellipses #'bound-def depth))
@@ -324,7 +263,12 @@
(if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
#'(begin)
#`(begin (define-temp-ids tmp-str binder-ddd)
- (define cached (free-id-table-ref! pvar-values-id
- (quote-syntax bound-def #:local)
- #'tmp-ddd))
- (define/with-syntax bound-ddd cached))))
-\ No newline at end of file
+ (define cached (hash-ref! (list-ref pvar-values-id
+ stx-scope-depth)
+ 'bound-def
+ #'tmp-ddd))
+ (define/with-syntax bound-ddd cached)
+ (define-syntax #,(format-id #'bound
+ " is-derived-~a "
+ #'bound)
+ (derived)))))
+\ No newline at end of file
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -9,14 +9,15 @@
(list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
(subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))]))
-#;(map syntax->datum
- (syntax-parse #'()
- [()
- (syntax-parse #'(a b c)
- [(xⱼ zᵢ …)
- (list (let () (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))
- (syntax-parse #'(e)
- [(e) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])]))
+(map syntax->datum
+ (syntax-parse #'()
+ [()
+ (syntax-parse #'(a b)
+ [(zᵢ …)
+ (list (syntax-parse #'(e)
+ [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
+ (syntax-parse #'(e)
+ [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])]))
#|
(define-syntax (tst stx)
