Changed subtemplate to use current-pvars+unique
This commit is contained in:
Georges Dupéron
parent
f1ede1dd4d
commit
1f2a9eaebb
377
main.rkt
377
main.rkt
|
|
@ -1,15 +1,15 @@
|
|||
#lang racket
|
||||
|
||||
(require racket/require
|
||||
phc-toolkit/untyped
|
||||
racket/stxparam
|
||||
syntax/parse
|
||||
backport-template-pr1514/experimental/template
|
||||
;syntax/parse/experimental/template
|
||||
;syntax/parse/experimental/private/substitute
|
||||
stxparse-info/parse
|
||||
stxparse-info/current-pvars
|
||||
stxparse-info/parse/experimental/template
|
||||
syntax/id-table
|
||||
racket/syntax
|
||||
(for-syntax "patch-arrows.rkt"
|
||||
syntax/parse
|
||||
(for-syntax phc-graph/patch-arrows
|
||||
stxparse-info/parse
|
||||
racket/private/sc
|
||||
racket/syntax
|
||||
racket/list
|
||||
|
|
@ -21,82 +21,27 @@
|
|||
syntax/contract
|
||||
racket/contract))
|
||||
|
||||
(provide (rename-out [new-syntax-parse syntax-parse]
|
||||
[new-syntax-parser syntax-parser]
|
||||
[new-syntax-case syntax-case])
|
||||
;define-unhygienic-template-metafunction
|
||||
subtemplate
|
||||
(provide subtemplate
|
||||
quasisubtemplate)
|
||||
|
||||
(begin-for-syntax (struct derived ()))
|
||||
(define-syntax-parameter maybe-syntax-pattern-variable-ids '())
|
||||
(define empty-pvar-values '())
|
||||
(define-syntax-parameter pvar-values-id (make-rename-transformer
|
||||
#'empty-pvar-values))
|
||||
(define derived-valvar-cache (make-weak-hash))
|
||||
|
||||
(begin-for-syntax
|
||||
(define/contract (split-colon sym)
|
||||
(-> symbol? (cons/c symbol? (listof symbol?)))
|
||||
(cons sym
|
||||
(map string->symbol
|
||||
(string-split (symbol->string sym)
|
||||
":")))))
|
||||
;; Act like a syntax transformer, but which is recognizable via the
|
||||
;; derived-pattern-variable? predicate.
|
||||
(struct derived-valvar (valvar)
|
||||
#:property prop:procedure
|
||||
(λ (self stx)
|
||||
#`(#%expression #,(derived-valvar-valvar self))))
|
||||
|
||||
(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? _)
|
||||
(append-map split-colon _)
|
||||
(remove-duplicates)))
|
||||
(syntax-parameter-value
|
||||
#'maybe-syntax-pattern-variable-ids)));)
|
||||
(define (id-is-derived-valvar? id)
|
||||
(define mapping (syntax-local-value id (thunk #f)))
|
||||
(and mapping ;; … defined as syntax
|
||||
(syntax-pattern-variable? mapping) ;; and is a syntax pattern variable
|
||||
(derived-valvar? ;; and the pvar's valvar is derived
|
||||
(syntax-local-value (syntax-mapping-valvar mapping)
|
||||
(thunk #f)))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define/contract (wrap-with-parameterize lctx new-whole-form rest)
|
||||
(-> identifier? syntax? syntax? syntax?)
|
||||
(quasisyntax/top-loc lctx
|
||||
(let ()
|
||||
#,(patch-arrows
|
||||
;; 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 (cons (make-hash) pvar-values-id)])
|
||||
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
|
||||
#,(new-scope rest lctx)]
|
||||
[pvar-values-id (make-rename-transformer
|
||||
#'the-pvar-values)])
|
||||
#,new-whole-form)))))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define/contract (simple-wrap-with-parameterize new-form-id)
|
||||
(-> identifier? (-> syntax? syntax?))
|
||||
(λ/syntax-case (self . rest) ()
|
||||
(wrap-with-parameterize #'self #`(#,new-form-id . rest) #'rest))))
|
||||
|
||||
(define-syntax new-syntax-parse
|
||||
(simple-wrap-with-parameterize #'syntax-parse))
|
||||
|
||||
(define-syntax new-syntax-case
|
||||
(simple-wrap-with-parameterize #'syntax-case))
|
||||
|
||||
(define-syntax (new-syntax-parser stx)
|
||||
(syntax-case stx ()
|
||||
[(self . rest)
|
||||
(quasisyntax/top-loc #'self
|
||||
(λ (stx2)
|
||||
#,(wrap-with-parameterize #'self
|
||||
#'((syntax-parser . rest) stx2)
|
||||
#'rest)))]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define/contract (string-suffix a b)
|
||||
(-> string? string? string?)
|
||||
(define suffix-length (string-suffix-length a b))
|
||||
|
|
@ -135,180 +80,223 @@
|
|||
(string-length sub)))])
|
||||
(datum->syntax id (string->symbol new-str) id id)))
|
||||
|
||||
(define/contract (find-subscript-binder2a lctx scopes bound scope-depth)
|
||||
(-> identifier?
|
||||
(listof (cons/c identifier? (listof symbol?)))
|
||||
identifier?
|
||||
exact-nonnegative-integer?
|
||||
(listof (list/c identifier? exact-nonnegative-integer?)))
|
||||
(if (null? scopes)
|
||||
'()
|
||||
(let ()
|
||||
(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-sym (in-list syms)]
|
||||
[binder (in-value (datum->syntax lctx binder-sym #f))]
|
||||
#:when (syntax-pattern-variable?
|
||||
(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)
|
||||
(list binder scope-depth)))
|
||||
(if (null? found-here)
|
||||
recur-found
|
||||
(append found-here recur-found)))))
|
||||
|
||||
(define/contract (find-subscript-binder2 bound)
|
||||
(-> identifier?
|
||||
(or/c #f (list/c identifier? ;; bound
|
||||
(syntax/c (listof identifier?)) ;; binders
|
||||
(syntax/c (listof identifier?)) ;; max-binders
|
||||
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 scope-depth] …)
|
||||
(find-subscript-binder2a bound ;; TODO: check this is okay (should be).
|
||||
scopes
|
||||
bound
|
||||
0))
|
||||
(if (stx-null? #'(binder …))
|
||||
#f
|
||||
(let ()
|
||||
(define depths
|
||||
(stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
|
||||
(unless (or (< (length depths) 2) (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)))
|
||||
(define max-scope-depth (apply max (syntax->datum #'(scope-depth …))))
|
||||
(define max-binders
|
||||
(sort (map car
|
||||
(filter (λ (bs) (= (syntax-e (cdr bs)) max-scope-depth))
|
||||
(stx-map syntax-e #'([binder . scope-depth] …))))
|
||||
symbol<?
|
||||
#:key syntax-e))
|
||||
(list bound
|
||||
#'(binder …)
|
||||
#`#,max-binders
|
||||
(car depths)
|
||||
max-scope-depth
|
||||
#'check-ellipsis-count-ddd))))
|
||||
|
||||
(define/contract (nest-ellipses stx n)
|
||||
(-> syntax? exact-nonnegative-integer? syntax?)
|
||||
(if (= n 0)
|
||||
stx
|
||||
#`(#,(nest-ellipses stx (sub1 n))
|
||||
(… …)))))
|
||||
(… …))))
|
||||
|
||||
(define/contract (find-subscript-binder bound)
|
||||
(-> identifier?
|
||||
(or/c #f (list/c identifier? ; bound
|
||||
(syntax/c (listof identifier?)) ; binders
|
||||
(syntax/c (listof identifier?)) ; unique-at-runtime ids
|
||||
exact-nonnegative-integer? ; ellipsis-depth
|
||||
syntax?))) ; check-ellipsis-count
|
||||
(let/cc return
|
||||
;; EARLY RETURN (already a pattern variable)
|
||||
(when (syntax-pattern-variable?
|
||||
(syntax-local-value bound (thunk #f)))
|
||||
(return #f))
|
||||
|
||||
(define/with-syntax ([binder . unique-at-runtime-id] …)
|
||||
(filter (compose (conjoin identifier?
|
||||
(negate id-is-derived-valvar?)
|
||||
(λ~> (syntax-local-value _ (thunk #f))
|
||||
syntax-pattern-variable?)
|
||||
;; force call syntax-local-value to prevent
|
||||
;; ambiguous bindings, as syntax-local-value
|
||||
;; triggers an error for those.
|
||||
;; Must be done before the free-identifier=?
|
||||
;; which just returns #false
|
||||
(λ~> (datum->syntax _ (syntax-e bound))
|
||||
(syntax-local-value _ (thunk #f))
|
||||
(thunk* #t)) ;; ok if no error.
|
||||
(λ~> (datum->syntax _ (syntax-e bound))
|
||||
(free-identifier=? _ bound))
|
||||
(λ~> (subscript-equal? bound _)))
|
||||
car)
|
||||
(current-pvars+unique)))
|
||||
|
||||
;; Or write it as:
|
||||
|
||||
#;(define/with-syntax ([binder . unique-at-runtime] …)
|
||||
(for/list ([binder (current-pvars)]
|
||||
#:when (identifier? (car binder))
|
||||
#:unless (id-is-derived-pvar? (car binder))
|
||||
#:when (syntax-pattern-variable?
|
||||
(syntax-local-value (car binder) (thunk #f)))
|
||||
;; force call syntax-local-value to prevent ambiguous
|
||||
;; bindings, as syntax-local-value triggers an error for
|
||||
;; those.
|
||||
;; Must be done before the free-identifier=? which just
|
||||
;; returns #false
|
||||
#:when (begin
|
||||
(syntax-local-value
|
||||
(datum->syntax _ (syntax-e bound))
|
||||
(thunk #f))
|
||||
#t) ;; ok if no error.
|
||||
#:when (free-identifier=? (datum->syntax (car binder)
|
||||
(syntax-e bound))
|
||||
bound)
|
||||
#:when (subscript-equal? bound (car binder)))
|
||||
binder))
|
||||
|
||||
;; EARLY RETURN (no candidate binders found)
|
||||
(when (stx-null? #'(binder …))
|
||||
(return #f))
|
||||
|
||||
(define depths
|
||||
(stx-map (∘ syntax-mapping-depth syntax-local-value) #'(binder …)))
|
||||
|
||||
;; EARLY ERROR (inconsistent depths)
|
||||
(unless (or (< (length depths) 2) (apply = depths))
|
||||
(car 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, by simply generating a dummy syntax object, with
|
||||
;; all the given binders nested under the right number of ellipses.
|
||||
(define/with-syntax check-ellipsis-count-ddd
|
||||
(nest-ellipses #'(binder …) (car depths)))
|
||||
|
||||
;; FINAL RETURN (list of same-depth binders + their depth)
|
||||
(list bound
|
||||
#'(binder …)
|
||||
#'(unique-at-runtime-id …)
|
||||
(car depths)
|
||||
#'check-ellipsis-count-ddd))))
|
||||
|
||||
(define-for-syntax/case-args ((sub*template tmpl-form) (self . tmpl))
|
||||
(define acc '())
|
||||
|
||||
;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ bindings
|
||||
(define (fold-process stx rec)
|
||||
(syntax-case stx ()
|
||||
[(id . _) (and (identifier? #'id)
|
||||
(free-identifier=? #'id #'unsyntax))
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
(let ([binders+info (find-subscript-binder2 #'id)])
|
||||
(let ([binders+info (find-subscript-binder #'id)])
|
||||
(when binders+info
|
||||
(set! acc (cons binders+info acc)))
|
||||
#'id)]
|
||||
[other (rec #'other)]))
|
||||
;; process the syntax, extract the derived bindings into acc
|
||||
;; Process the syntax, extract the derived bindings into acc
|
||||
;; Does not take zᵢ identifiers generated by template metafunctions into
|
||||
;; account for now.
|
||||
(fold-syntax fold-process #'tmpl)
|
||||
|
||||
;; define the result, which looks like (template . tmpl) or
|
||||
;; like (quasitemplate . tmpl)
|
||||
(define result
|
||||
(quasisyntax/top-loc #'self
|
||||
(#,tmpl-form
|
||||
. tmpl)))
|
||||
(#,tmpl-form . tmpl)))
|
||||
;; Make sure that we remove duplicates, otherwise we'll get errors if we
|
||||
;; define the same derived id twice.
|
||||
(define/with-syntax ([bound binders
|
||||
max-binders
|
||||
depth
|
||||
scope-depth
|
||||
check-ellipsis-count] …)
|
||||
(define/with-syntax ([bound
|
||||
binders
|
||||
unique-at-runtime-ids
|
||||
ellipsis-depth
|
||||
check-ellipsis-count]
|
||||
…)
|
||||
(remove-duplicates acc #:key car))
|
||||
|
||||
#`(let ()
|
||||
(derive bound binders max-binders depth scope-depth)
|
||||
(derive bound binders unique-at-runtime-ids ellipsis-depth)
|
||||
…
|
||||
(let ()
|
||||
;; no-op, just to raise an error when they are incompatible
|
||||
#'(check-ellipsis-count …)
|
||||
#'(check-ellipsis-count …) ;; TODO: allow #f values for ~optional in syntax/parse ;;;;;;;;;;;;;;
|
||||
;; actually call template or quasitemplate
|
||||
#,result)))
|
||||
|
||||
(define-syntax subtemplate (sub*template #'template))
|
||||
(define-syntax quasisubtemplate (sub*template #'quasitemplate))
|
||||
|
||||
(define/contract (multi-hash-ref! h keys to-set)
|
||||
;; This assumes that the hash does not get mutated during the execution of
|
||||
;; this function.
|
||||
(-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?)
|
||||
(listof symbol?)
|
||||
any/c
|
||||
any/c)
|
||||
(define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f))
|
||||
to-set))
|
||||
(for ([k (in-list keys)]) (hash-ref! h k val))
|
||||
val)
|
||||
|
||||
(define/contract ((stx-list*+stx/c depth) l)
|
||||
(-> exact-nonnegative-integer? (-> any/c boolean?))
|
||||
(if (= depth 0)
|
||||
(syntax? l)
|
||||
(and (syntax? l)
|
||||
(syntax->list l)
|
||||
(andmap (λ (lᵢ) ((stx-list*+stx/c (sub1 depth)) lᵢ))
|
||||
(syntax->list l)))))
|
||||
|
||||
(define-syntax/case (derive bound binders max-binders stx-depth stx-scope-depth)
|
||||
()
|
||||
;; TODO: shouldn't it be called in the first place?
|
||||
(if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
|
||||
#'(begin)
|
||||
#'(derive2 bound binders max-binders stx-depth stx-scope-depth)))
|
||||
(define/contract ((list*+stx/c depth) l)
|
||||
(-> exact-nonnegative-integer? (-> any/c boolean?))
|
||||
(if (= depth 0)
|
||||
(syntax? l)
|
||||
(and (list? l)
|
||||
(andmap (λ (lᵢ) ((list*+stx/c (sub1 depth)) lᵢ))
|
||||
l))))
|
||||
|
||||
(define-syntax/case (derive2 bound
|
||||
binders
|
||||
(max-binder0 . max-binders)
|
||||
stx-depth
|
||||
stx-scope-depth) ()
|
||||
(define depth (syntax-e #'stx-depth))
|
||||
(define/contract (destructure-stx-list* l depth)
|
||||
(->i ([l (depth) (stx-list*+stx/c depth)]
|
||||
[depth exact-nonnegative-integer?])
|
||||
[range (depth) (list*+stx/c depth)])
|
||||
(if (= depth 0)
|
||||
l
|
||||
(stx-map (λ (lᵢ) (destructure-stx-list* lᵢ (sub1 depth)))
|
||||
l)))
|
||||
|
||||
(define-syntax/case (derive bound
|
||||
(binder₀ binderᵢ …)
|
||||
(unique-at-runtime-idᵢ …)
|
||||
ellipsis-depth) ()
|
||||
(define depth (syntax-e #'ellipsis-depth))
|
||||
(define/with-syntax bound-ddd (nest-ellipses #'bound depth))
|
||||
(define/with-syntax tmp-id
|
||||
(format-id #'here "~a/~a" #'max-binder0 (drop-subscripts #'bound)))
|
||||
(format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound)))
|
||||
(define/with-syntax tmp-str
|
||||
(datum->syntax #'tmp-id
|
||||
(symbol->string
|
||||
(syntax-e
|
||||
(format-id #'here "~~a/~a" (drop-subscripts #'bound))))))
|
||||
(define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
|
||||
(define/with-syntax binder-ddd (nest-ellipses #'max-binder0 depth))
|
||||
(define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth))
|
||||
|
||||
;; Draw arrows in DrRacket.
|
||||
(with-arrows
|
||||
(define subscripts (subscript-equal? #'bound #'max-binder0))
|
||||
(define subscripts (subscript-equal? #'bound #'binder₀))
|
||||
(define bound-id-str (identifier->string #'bound))
|
||||
(for ([max-binder (in-list (syntax->list #'(max-binder0 . max-binders)))])
|
||||
(define binder-id-str (identifier->string max-binder))
|
||||
(for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))])
|
||||
(define binder-id-str (identifier->string binder))
|
||||
(record-sub-range-binders! (vector #'bound
|
||||
(- (string-length bound-id-str)
|
||||
(string-length subscripts))
|
||||
(string-length subscripts)
|
||||
max-binder
|
||||
binder
|
||||
(- (string-length binder-id-str)
|
||||
(string-length subscripts))
|
||||
(string-length subscripts))))
|
||||
#;(define binder0-id-str (identifier->string #'max-binder0))
|
||||
#;(define binder0-id-str (identifier->string #'binder0))
|
||||
#;(record-sub-range-binders! (vector #'bound
|
||||
(- (string-length bound-id-str)
|
||||
(string-length subscripts))
|
||||
(string-length subscripts)
|
||||
#'max-binder0
|
||||
#'binder0
|
||||
(- (string-length binder0-id-str)
|
||||
(string-length subscripts))
|
||||
(string-length subscripts)))
|
||||
(define/with-syntax temp-derived (generate-temporary #'bound))
|
||||
(define/with-syntax temp-cached (generate-temporary #'bound))
|
||||
;; 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.
|
||||
|
|
@ -322,11 +310,16 @@
|
|||
;; zᵢ …))])
|
||||
;; 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 (hash-ref! (list-ref pvar-values-id
|
||||
stx-scope-depth)
|
||||
'bound
|
||||
#'tmp-ddd))
|
||||
(define/with-syntax bound-ddd cached)
|
||||
(define-syntax #,(format-id #'bound " is-derived-~a " #'bound)
|
||||
(derived)))))
|
||||
#`(begin (define-temp-ids #:concise tmp-str binder-ddd)
|
||||
(define temp-cached
|
||||
(free-id-table-ref! (multi-hash-ref! derived-valvar-cache
|
||||
'(unique-at-runtime-idᵢ …)
|
||||
(make-free-id-table))
|
||||
(quote-syntax bound)
|
||||
(destructure-stx-list* #'tmp-ddd
|
||||
'ellipsis-depth)))
|
||||
(define-syntax temp-derived
|
||||
(derived-valvar (quote-syntax temp-cached)))
|
||||
(define-syntax bound
|
||||
(make-syntax-mapping 'ellipsis-depth (quote-syntax temp-derived)))
|
||||
(define-pvars bound))))
|
||||
20
test/assumption-free-identifier-equal.rkt
Normal file
20
test/assumption-free-identifier-equal.rkt
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
#lang racket
|
||||
(define-for-syntax outer #f)
|
||||
(define-for-syntax inner #f)
|
||||
(let ([x 1])
|
||||
(define-syntax (capture1 stx)
|
||||
(set! outer #'x)
|
||||
#'(void))
|
||||
(capture1)
|
||||
(let ([x 2])
|
||||
(define-syntax (capture2 stx)
|
||||
(set! inner #'x)
|
||||
#'(void))
|
||||
(capture2)
|
||||
(let ([y 3])
|
||||
(define-syntax (compare stx)
|
||||
(define candidate (datum->syntax #'y 'x))
|
||||
(displayln (free-identifier=? candidate inner))
|
||||
(displayln (free-identifier=? candidate outer))
|
||||
#'(void))
|
||||
(compare))))
|
||||
24
test/assumption-weak-hash.rkt
Normal file
24
test/assumption-weak-hash.rkt
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#lang racket
|
||||
|
||||
(require (for-syntax racket/private/sc))
|
||||
|
||||
(define h (make-weak-hasheq))
|
||||
|
||||
(define (all-eq? l)
|
||||
(foldl (λ (x acc)
|
||||
(and (eq? x acc) acc))
|
||||
(car l)
|
||||
(cdr l)))
|
||||
|
||||
(for/list ([range-a (in-range 100)])
|
||||
(with-syntax ([(xᵢ ...) #'(1 2 3)])
|
||||
(define-syntax (hh stx)
|
||||
#`(hash-ref! h
|
||||
#,(syntax-mapping-valvar (syntax-local-value #'xᵢ))
|
||||
(gensym)))
|
||||
(displayln (hash->list h))
|
||||
(all-eq? (for/list ([range-b (in-range 5)])
|
||||
;(collect-garbage)
|
||||
;(collect-garbage)
|
||||
;(collect-garbage)
|
||||
(hh)))))
|
||||
|
|
@ -1,5 +1,7 @@
|
|||
#lang racket
|
||||
(require "../subtemplate.rkt"
|
||||
(require subtemplate
|
||||
stxparse-info/parse
|
||||
stxparse-info/case
|
||||
phc-toolkit/untyped
|
||||
rackunit)
|
||||
|
||||
|
|
@ -22,11 +24,70 @@
|
|||
|
||||
|#
|
||||
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate foo)]))
|
||||
'foo)
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate foo)]))
|
||||
'foo)
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate xⱼ)]))
|
||||
'b)
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate xⱼ)]))
|
||||
'b)
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (zᵢ …))]))
|
||||
'(c d))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (zᵢ …))]))
|
||||
'(c d))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (wᵢ …))]))
|
||||
'(c/w d/w))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (wᵢ …))]))
|
||||
'(c/w d/w))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (kⱼ wᵢ …))]))
|
||||
'(b/k c/w d/w))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (kⱼ wᵢ …))]))
|
||||
'(b/k c/w d/w))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (xⱼ kⱼ (zᵢ wᵢ) …))]))
|
||||
'(b b/k (c c/w) (d d/w)))
|
||||
|
||||
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
||||
[(_ xⱼ zᵢ …)
|
||||
(subtemplate (xⱼ kⱼ (wᵢ zᵢ) …))]))
|
||||
'(b b/k (c/w c) (d/w d)))
|
||||
|
||||
|
||||
|
||||
|
||||
#;(let ()
|
||||
(syntax-parse #'a #;(syntax-parse #'(a b c d)
|
||||
[(_ xⱼ zᵢ …)
|
||||
|
|
@ -427,7 +488,7 @@
|
|||
(check free-identifier=? #'zz2 #'b)
|
||||
|
||||
(check free-identifier=? #'x1 #'x2)
|
||||
(check (∘ not free-identifier=?) #'w1 #'w2) ;; yes above, no here.
|
||||
(check (∘ not bound-identifier=?) #'w1 #'w2) ;; yes above, no here.
|
||||
(check free-identifier=? #'foo1 #'foo2)
|
||||
(check free-identifier=? #'z1 #'z2)
|
||||
(check free-identifier=? #'p1 #'p2)
|
||||
|
|
|
|||
18
test/wrong-assumption-with-syntax-eq.rkt
Normal file
18
test/wrong-assumption-with-syntax-eq.rkt
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
#lang racket
|
||||
(require (for-syntax racket/private/sc))
|
||||
|
||||
(define old #f)
|
||||
|
||||
(for/list ([range-a (in-range 100)])
|
||||
;; The contents of the valvar is eq? when using a literal syntax object
|
||||
;; #'(1 2 3), but not with (datum->syntax #'here '(1 2 3)).
|
||||
;; I expected the result to always be different at each execution of the
|
||||
;; with-syntax, but it turns out the syntax object is kept as-is.
|
||||
(with-syntax ([(xᵢ ...) #'(1 2 3) #;(datum->syntax #'here '(1 2 3))])
|
||||
(define-syntax (hh stx)
|
||||
#`#,(syntax-mapping-valvar (syntax-local-value #'xᵢ)))
|
||||
(unless old
|
||||
(displayln "initial set!")
|
||||
(set! old (hh)))
|
||||
(andmap identity (for/list ([range-b (in-range 5)])
|
||||
(eq? old hh)))))
|
||||
Loading…
Reference in New Issue
Block a user