commit f4adf61aba5f1c4a0a4f17b6f2d62ce4b0413e3b
parent 41013e5ef404e853e89e9490eedcfc874aef1a06
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 6 Oct 2016 02:02:23 +0200
WIP
Diffstat:
| M | subtemplate.rkt | | | 194 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------- |
| M | test/test-subtemplate.rkt | | | 134 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------- |
2 files changed, 264 insertions(+), 64 deletions(-)
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -11,6 +11,7 @@
racket/list
racket/function
phc-toolkit/untyped
+ syntax/strip-context
srfi/13
racket/contract))
@@ -21,11 +22,43 @@
(for-syntax find-subscript-binder)) ;; for testing only
(define-syntax-parameter maybe-syntax-pattern-variable-ids '())
-(define-syntax-parameter pvar-values-id #f)
+(define empty-pvar-values #f)
+(define-syntax-parameter pvar-values-id (make-rename-transformer
+ #'empty-pvar-values))
(define-syntax/parse (new-syntax-parse . rest)
(quasisyntax/top-loc (stx-car stx)
- (let ([the-pvar-values (make-free-id-table)])
+ ;; HERE insert a hash table, to cache the uses
+ ;; 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.
+ (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)))]
+ [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?
@@ -35,30 +68,7 @@
#'maybe-syntax-pattern-variable-ids))]
[pvar-values-id (make-rename-transformer
#'the-pvar-values)])
- (syntax-parse . rest))
- #;(syntax-parse option …
- [clause-pat
- ;; HERE insert a hash table, to cache the uses
- ;; 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.
- #:do (define #,(lifted-scope (syntax-local-introduce #'pvar-values)
- 'add)
- (make-free-id-table))
- . clause-rest]
- …))))
-
-(define-syntax/case (new-syntax-case . rest) ()
- (quasisyntax/top-loc (stx-car stx)
- (syntax-parameterize ([maybe-syntax-pattern-variable-ids
- (cons '#,(remove-duplicates
- (filter symbol?
- (flatten
- (syntax->datum #'rest))))
- (syntax-parameter-value
- #'maybe-syntax-pattern-variable-ids))])
- (syntax-case . rest))))
+ (syntax-case . rest)))))
(begin-for-syntax
(define/contract (string-suffix a b)
@@ -78,23 +88,99 @@
[subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
(and subs (car subs)))))
+ (define/contract (subscript-equal? bound binder)
+ (-> identifier? identifier? (or/c #f string?))
+ (and (let* ([binder-string (symbol->string (syntax-e binder))]
+ [bound-string (symbol->string (syntax-e bound))]
+ [binder-s (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$" binder)]
+ [bound-s (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$" bound)])
+ (equal? (car binder-s)
+ (car bound-s)))))
+
+ (define/contract (derived? binder)
+ (-> identifier? boolean?)
+ (displayln 'TODO-89641)
+ #f)
+
+ (define/contract (find-subscript-binder2a scopes bound)
+ (-> (listof (listof identifier?)) identifier? (listof identifier?))
+ (if (null? scopes)
+ '()
+ (let ()
+ (define scope (car scopes))
+ (define recur-found (find-subscript-binder2a (cdr scopes) bound))
+ (define found-here
+ (for*/list ([binder (in-list scope)]
+ #:when (syntax-pattern-variable?
+ (syntax-local-value binder
+ (thunk #f)))
+ #:when (not (derived? binder))
+ [subscripts (in-value (subscript-equal? bound
+ binder))]
+ #:when subscripts)
+ (list binder subscripts)))
+ (if (null? found-here)
+ recur-found
+ (append found-here recur-found)))))
+
+ (define/contract (find-subscript-binder2 scopes bound)
+ (-> (listof (listof identifier?))
+ identifier?
+ (or/c #f (syntax/c (cons/c syntax? (listof identifier?)))))
+ (define/with-syntax (binder …) (find-subscript-binder2a scopes bound))
+ (if (stx-null? #'(binder …))
+ #f
+ (let ()
+ (define depths
+ (stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
+ (unless (apply = depths)
+ (raise-syntax-error 'subtemplate
+ (format "inconsistent depths: ~a"
+ (syntax->list #'(binder …)))
+ bound))
+ ;; generate code to check that the bindings have all the same
+ ;; ellipsis count
+ (define/with-syntax check-ellipsis-count-ddd
+ (nest-ellipses #'(binder …) (car depths)))
+ (values #'(check-ellipsis-count-ddd binder …)))))
+
(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))])
+ #'maybe-syntax-pattern-variable-ids))]
+ [scope-depth (in-naturals)])
(define result
- (for*/list ([sym (in-list scope)]
- #:unless (string=? (symbol->string sym)
+ (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))
- [binder (in-value (datum->syntax bound sym))]
[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))
- (car (argmax (∘ string-length cdr) 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))
@@ -106,9 +192,10 @@
(… …)))))
(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 depth))
- (define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder #'bound))
+ (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))
@@ -127,26 +214,39 @@
;; the test above is not exactly right (zᵢ will still have the correct
;; binding), but it gives the general idea.
- #`(begin (define-temp-ids tmp-str binder-ddd)
- (define cached (free-id-table-ref! pvar-values-id
- (quote-syntax bound)
- #'tmp-ddd))
- (define/with-syntax bound-ddd cached)))
+ ;; 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)
+ (syntax-case stx ()
+ [(id . _) (and (identifier? #'id)
+ (free-identifier=? #'id #'unsyntax))
+ stx]
+ [id (identifier? #'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)]
+ [other (rec #'other)]))
(define result
(quasisyntax/top-loc #'self
(#,tmpl-form
- . #,(fold-syntax (λ (stx rec)
- (if (identifier? stx)
- (let ([binder (find-subscript-binder stx #f)])
- (when binder
- (let ([depth (syntax-mapping-depth
- (syntax-local-value binder))])
- (set! acc `((,stx ,binder ,depth) . ,acc))))
- stx)
- (rec stx)))
+ . #,(fold-syntax fold-process
#'tmpl))))
;; Make sure that we remove duplicates, otherwise we'll get errors if we use
;; the same derived id twice.
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -2,7 +2,7 @@
(require "../subtemplate.rkt"
phc-toolkit/untyped
rackunit)
-
+#|
(define-syntax (tst stx)
(syntax-case stx ()
[(_ tt)
@@ -190,19 +190,118 @@
;; the test above is not exactly right (zᵢ will still have the correct
;; binding), but it gives the general idea.
-(syntax->datum
- (syntax-parse #'(a b c)
- [(xᵢ …)
- (define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
- (quasisubtemplate (yᵢ …
- ;; must be from xᵢ, not yᵢ
- #,flob
- zᵢ …))]))
-
-(syntax->datum
- (syntax-parse #'(a b c)
- [(xᵢ …)
- (quasisubtemplate (yᵢ …
- ;; must be from xᵢ, not yᵢ
- #,(syntax-parse #'d [d (quasisubtemplate (zᵢ …))])
- zᵢ …))]))
+(syntax-parse (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,flob
+ zᵢ …))])
+ [(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
+ (check free-identifier=? #'a2 #'a3)
+ (check free-identifier=? #'b2 #'b3)
+ (check free-identifier=? #'c2 #'c3)
+ (check (∘ not free-identifier=?) #'a1 #'a2)
+ (check (∘ not free-identifier=?) #'b1 #'b2)
+ (check (∘ not free-identifier=?) #'c1 #'c2)])
+
+(syntax-parse (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,(syntax-parse #'d
+ [d (quasisubtemplate (zᵢ …))])
+ zᵢ …))])
+ [(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
+ (check free-identifier=? #'a2 #'a3)
+ (check free-identifier=? #'b2 #'b3)
+ (check free-identifier=? #'c2 #'c3)
+ (check (∘ not free-identifier=?) #'a1 #'a2)
+ (check (∘ not free-identifier=?) #'b1 #'b2)
+ (check (∘ not free-identifier=?) #'c1 #'c2)])
+
+(syntax-parse (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,(syntax-parse #'d
+ [d (quasisubtemplate (zᵢ …))])
+ #,(syntax-parse #'d
+ [d (quasisubtemplate (zᵢ …))])
+ zᵢ …))])
+ [(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
+ (check free-identifier=? #'a2 #'a3)
+ (check free-identifier=? #'b2 #'b3)
+ (check free-identifier=? #'c2 #'c3)
+
+ (check free-identifier=? #'a3 #'a4)
+ (check free-identifier=? #'b3 #'b4)
+ (check free-identifier=? #'c3 #'c4)
+
+ (check free-identifier=? #'a2 #'a4)
+ (check free-identifier=? #'b2 #'b4)
+ (check free-identifier=? #'c2 #'c4)
+
+ (check (∘ not free-identifier=?) #'a1 #'a2)
+ (check (∘ not free-identifier=?) #'b1 #'b2)
+ (check (∘ not free-identifier=?) #'c1 #'c2)])
+
+(syntax-parse (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,(syntax-parse #'d
+ [d (quasisubtemplate (kᵢ …))])
+ #,(syntax-parse #'d
+ [d (quasisubtemplate (kᵢ …))])
+ zᵢ …))])
+ [(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
+ (check free-identifier=? #'a2 #'a3)
+ (check free-identifier=? #'b2 #'b3)
+ (check free-identifier=? #'c2 #'c3)
+
+ (check (∘ not free-identifier=?) #'a1 #'a2)
+ (check (∘ not free-identifier=?) #'b1 #'b2)
+ (check (∘ not free-identifier=?) #'c1 #'c2)
+
+ (check (∘ not free-identifier=?) #'a2 #'a4)
+ (check (∘ not free-identifier=?) #'b2 #'b4)
+ (check (∘ not free-identifier=?) #'c2 #'c4)
+
+ (check (∘ not free-identifier=?) #'a3 #'a4)
+ (check (∘ not free-identifier=?) #'b3 #'b4)
+ (check (∘ not free-identifier=?) #'c3 #'c4)])
+|#
+
+(map syntax->datum
+ (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (list (syntax-parse #'(d)
+ [(pᵢ …) #`(#,(quasisubtemplate (xᵢ … pᵢ … zᵢ …))
+ #,(quasisubtemplate (xᵢ … pᵢ … zᵢ …)))])
+ (syntax-parse #'(e)
+ [(pᵢ …) (quasisubtemplate (xᵢ … pᵢ … zᵢ …))]))]))
+
+#;(syntax->datum
+ (syntax-parse #'(a b c)
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,(syntax-parse #'(d)
+ [(pᵢ …) (quasisubtemplate (pᵢ … zᵢ …))])
+ ;; GIVES WRONG ID (re-uses the one above, shouldn't):
+ #,(syntax-parse #'(e)
+ [(pᵢ …) (quasisubtemplate (pᵢ … zᵢ …))])
+ wᵢ …))]))
+
+#|
+(syntax-parse #'(a b c)
+ [(xᵢ …)
+ (quasisubtemplate (yᵢ …
+ ;; must be from xᵢ, not yᵢ
+ #,(syntax-parse #'d
+ [zᵢ (quasisubtemplate (zᵢ …))])
+ #,(syntax-parse #'e
+ [zᵢ (quasisubtemplate (zᵢ …))])
+ zᵢ …))])
+|#
+\ No newline at end of file
