suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

Hopefully fixed scope issues with subtemplate

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-06 16:56:19 +02:00
parent 29bf4ef88a
commit 6921eb0e67
2 changed files with 119 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

242
subtemplate.rkt
View File

@ -13,52 +13,51 @@
phc-toolkit/untyped phc-toolkit/untyped
syntax/strip-context syntax/strip-context
srfi/13 srfi/13
syntax/contract
racket/contract)) racket/contract))
(provide (rename-out [new-syntax-parse syntax-parse] (provide (rename-out [new-syntax-parse syntax-parse]
[new-syntax-case syntax-case]) [new-syntax-case syntax-case])
subtemplate subtemplate
quasisubtemplate quasisubtemplate)
(for-syntax find-subscript-binder)) ;; for testing only
(begin-for-syntax (struct derived ())) (begin-for-syntax (struct derived ()))
(define-syntax-parameter maybe-syntax-pattern-variable-ids '()) (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 (define-syntax-parameter pvar-values-id (make-rename-transformer
#'empty-pvar-values)) #'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) (define-syntax/parse (new-syntax-parse . rest)
(quasisyntax/top-loc (stx-car stx) (quasisyntax/top-loc (stx-car stx)
;; HERE insert a hash table, to cache the uses ;; HERE insert a hash table, to cache the uses of derived pvars.
;; lifting the define-temp-ids is not likely to work, as they ;; Lifting the define-temp-ids is not likely to work, as they
;; need to define syntax pattern variables so that other macros ;; need to define syntax pattern variables so that other macros
;; can recognize them. Instead, we only lift the values, but still ;; can recognize them. Instead, we only lift the values, but still
;; do the bindings around the subtemplate. ;; do the bindings around the subtemplate.
(let ([the-pvar-values (or pvar-values-id (make-free-id-table))]) (let ([the-pvar-values (cons (make-hash) pvar-values-id)])
;; TODO: add a let before calling get-shadower.
(syntax-parameterize ([maybe-syntax-pattern-variable-ids (syntax-parameterize ([maybe-syntax-pattern-variable-ids
((λ (x) #;(displayln x) x) #,(new-scope #'rest (stx-car stx))]
(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 [pvar-values-id (make-rename-transformer
#'the-pvar-values)]) #'the-pvar-values)])
(syntax-parse . rest))))) (syntax-parse . rest)))))
(define-syntax/case (new-syntax-case . rest) () (define-syntax/case (new-syntax-case . rest) ()
(quasisyntax/top-loc (stx-car stx) (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))]) (let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
(syntax-parameterize ([maybe-syntax-pattern-variable-ids (syntax-parameterize ([maybe-syntax-pattern-variable-ids
(cons '#,(remove-duplicates (cons '#,(remove-duplicates
@ -99,55 +98,75 @@
(let* ([binder-subscripts (extract-subscripts binder)] (let* ([binder-subscripts (extract-subscripts binder)]
[bound-subscripts (extract-subscripts bound)]) [bound-subscripts (extract-subscripts bound)])
(and (string=? binder-subscripts bound-subscripts) (and (string=? binder-subscripts bound-subscripts)
(not (string=? binder-subscripts ""))
binder-subscripts))) binder-subscripts)))
(define/contract (derived? binder) (define/contract (find-subscript-binder2a lctx scopes bound scope-depth)
(-> identifier? boolean?) (-> identifier?
(displayln 'TODO-89641) (listof (cons/c identifier? (listof symbol?)))
#f)
(define/contract (find-subscript-binder2a scopes bound)
(-> (listof (listof identifier?))
identifier? identifier?
(listof identifier?)) exact-nonnegative-integer?
(listof (list/c identifier? exact-nonnegative-integer?)))
(if (null? scopes) (if (null? scopes)
'() '()
(let () (let ()
(define scope (car scopes)) (define outer-lctx (caar scopes))
(define recur-found (find-subscript-binder2a (cdr scopes) bound)) (define syms (cdar scopes))
(define recur-found (find-subscript-binder2a outer-lctx
(cdr scopes)
bound
(add1 scope-depth)))
(define found-here (define found-here
(for*/list ([binder (in-list scope)] (for*/list ([binder-sym (in-list syms)]
#:when (displayln (list (syntax-e bound) (syntax-e binder) [binder (in-value (datum->syntax lctx binder-sym))]
#;#:when #;(displayln (list bound binder
'pvar?= (syntax-pattern-variable? 'pvar?= (syntax-pattern-variable?
(syntax-local-value (replace-context bound binder) (syntax-local-value binder (thunk #f)))
'derived?= (derived?
(syntax-local-value
(format-id binder
" is-derived-~a "
binder)
(thunk #f))) (thunk #f)))
'derived= (not (derived? binder)) (subscript-equal? bound
'subscripts= (subscript-equal? bound
binder))) binder)))
#:when (syntax-pattern-variable? #:when (syntax-pattern-variable?
(syntax-local-value (replace-context bound binder) ;; why do I need replace-context here??? (syntax-local-value binder (thunk #f)))
(thunk #f))) #:when (not (derived?
#:when (not (derived? binder)) (syntax-local-value
(format-id binder
" is-derived-~a "
binder)
(thunk #f))))
[subscripts (in-value (subscript-equal? bound [subscripts (in-value (subscript-equal? bound
binder))] binder))]
#:when subscripts) #:when subscripts)
binder)) ;(displayln (list binder scope-depth))
(list binder scope-depth)))
;(displayln (list* 'found-here= bound '→ found-here))
(if (null? found-here) (if (null? found-here)
recur-found recur-found
(append found-here recur-found))))) (append found-here recur-found)))))
(define/contract (find-subscript-binder2 bound) (define/contract (find-subscript-binder2 bound)
(-> identifier? (-> identifier?
(or/c #f (list/c (syntax/c (listof identifier?)) (or/c #f (list/c identifier? ;; bound
exact-nonnegative-integer? (syntax/c (listof identifier?)) ;; bindings
syntax?))) 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 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 …)) (if (stx-null? #'(binder …))
#f #f
(let () (let ()
(define depths (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)) (unless (or (< (length depths) 2) (apply = depths))
(raise-syntax-error 'subtemplate (raise-syntax-error 'subtemplate
(format "inconsistent depths: ~a" (format "inconsistent depths: ~a"
@ -157,47 +176,11 @@
;; ellipsis count ;; ellipsis count
(define/with-syntax check-ellipsis-count-ddd (define/with-syntax check-ellipsis-count-ddd
(nest-ellipses #'(binder …) (car depths))) (nest-ellipses #'(binder …) (car depths)))
(list #'(binder …) (car depths) #'check-ellipsis-count-ddd)))) (list bound
#'(binder …)
(define/contract (find-subscript-binder bound [fallback bound]) (car depths)
(->* (identifier?) (any/c) (or/c identifier? any/c)) (apply max (syntax->datum #'(scope-depth …)))
(define result/scopes #'check-ellipsis-count-ddd))))
(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))
(define/contract (nest-ellipses stx n) (define/contract (nest-ellipses stx n)
(-> syntax? exact-nonnegative-integer? syntax?) (-> syntax? exact-nonnegative-integer? syntax?)
@ -206,43 +189,6 @@
#`(#,(nest-ellipses stx (sub1 n)) #`(#,(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-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
(define acc '()) (define acc '())
(define (fold-process stx rec) (define (fold-process stx rec)
@ -253,15 +199,8 @@
[id (identifier? #'id) [id (identifier? #'id)
(let ([binders (find-subscript-binder2 #'id)]) (let ([binders (find-subscript-binder2 #'id)])
(when binders (when binders
(displayln (syntax->datum (datum->syntax #f (cons #'id binders)))) ;(displayln (syntax->datum (datum->syntax #f binders)))
(set! acc (cons (cons #'id binders) (set! acc (cons binders acc)))
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)] #'id)]
[other (rec #'other)])) [other (rec #'other)]))
(define result (define result
@ -271,22 +210,22 @@
#'tmpl)))) #'tmpl))))
;; Make sure that we remove duplicates, otherwise we'll get errors if we ;; Make sure that we remove duplicates, otherwise we'll get errors if we
;; define the same derived id twice. ;; define the same derived id twice.
(define/with-syntax ([bound (binder0 . binders) depth check-ellipsis-count] …) (define/with-syntax ([bound (binder0 . binders)
(remove-duplicates acc free-identifier=? #:key car)) depth
#;(define/with-syntax ([bound binder depth] …) scope-depth
(remove-duplicates acc free-identifier=? #:key car)) 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 () #`(let ()
#;(derive bound binder depth) (derive2 bound binder0 (binder0 . binders) depth scope-depth)
(derive2 bound binder0 (binder0 . binders) depth)
… …
(let () (let ()
#'#,(replace-context ;; TODO: this is most certainly wrong ;; no-op, just to raise an error when they are incompatible
(stx-car #'(bound …)) #'(check-ellipsis-count …)
#'(check-ellipsis-count …)) ;; actually call template or quasitemplate
#,result))) #,result)))
(define-syntax subtemplate (sub*template #'template)) (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/with-syntax bound-def #'bound #;(replace-context #'binder0 #'bound))
(define depth (syntax-e #'stx-depth)) (define depth (syntax-e #'stx-depth))
(define/with-syntax bound-ddd (nest-ellipses #'bound-def 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))) (if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
#'(begin) #'(begin)
#`(begin (define-temp-ids tmp-str binder-ddd) #`(begin (define-temp-ids tmp-str binder-ddd)
(define cached (free-id-table-ref! pvar-values-id (define cached (hash-ref! (list-ref pvar-values-id
(quote-syntax bound-def #:local) stx-scope-depth)
'bound-def
#'tmp-ddd)) #'tmp-ddd))
(define/with-syntax bound-ddd cached)))) (define/with-syntax bound-ddd cached)
(define-syntax #,(format-id #'bound
" is-derived-~a "
#'bound)
(derived)))))

11
test/test-subtemplate.rkt
View File

@ -9,14 +9,15 @@
(list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)) (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
(subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))]))
#;(map syntax->datum (map syntax->datum
(syntax-parse #'() (syntax-parse #'()
[() [()
(syntax-parse #'(a b c) (syntax-parse #'(a b)
[(xⱼ zᵢ …) [(zᵢ …)
(list (let () (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))) (list (syntax-parse #'(e)
[(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
(syntax-parse #'(e) (syntax-parse #'(e)
[(e) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])) [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])]))
#| #|
(define-syntax (tst stx) (define-syntax (tst stx)