commit 8bf23152819d75676d534c462fd0abd18c7997a3
parent 39e703b12798cb03b8d24bec551296a88efea29b
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 26 Jan 2017 19:32:06 +0100
Closes FB case 189 Switch phc-graph to the packaged subtemplate
Diffstat:
13 files changed, 18 insertions(+), 1257 deletions(-)
diff --git a/fully-expanded-grammar-extract-bindings.rkt b/fully-expanded-grammar-extract-bindings.rkt
@@ -1,109 +0,0 @@
-#lang racket/base
-
-;; This file is based on the file fully-expanded-grammar.rkt in the same folder.
-
-(require syntax/parse
- phc-toolkit/untyped
- racket/contract
- racket/list
- (for-template '#%kernel))
-
-(provide extract-bindings)
-
-(define acc (make-parameter #f))
-
-(define/contract (acc! v)
- (-> identifier? void?)
- (set-box! (acc) (cons v (unbox (acc)))))
-
-(define-syntax-class acc-id
- #:attributes ()
- (pattern {~and id:id
- {~do (acc! #'id)}}))
-
-(define/contract (extract-bindings e)
- (-> syntax? (listof identifier?))
- (parameterize ([acc (box '())])
- (syntax-parse e
- [:expr 'ok])
- (fold-syntax (λ (stx rec)
- (let ([d (syntax-property stx 'disappeared-binding)])
- (for-each acc! (filter identifier? (flatten d))))
- (rec stx))
- e)
- (unbox (acc))))
-
-(define-syntax-class top-level-form
- #:literals (#%expression module #%plain-module-begin begin begin-for-syntax)
- (pattern :general-top-level-form)
- (pattern (#%expression :expr))
- (pattern (module :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (begin :top-level-form …))
- (pattern (begin-for-syntax :top-level-form …)))
-
-(define-syntax-class module-level-form
- #:literals (#%provide begin-for-syntax #%declare)
- (pattern :general-top-level-form)
- (pattern (#%provide _raw-provide-spec …))
- (pattern (begin-for-syntax :module-level-form …))
- (pattern :submodule-form)
- (pattern (#%declare _declaration-keyword …)))
-
-(define-syntax-class submodule-form
- #:literals (module #%plain-module-begin module* )
- (pattern (module :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (module* :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (module* :id #f
- (#%plain-module-begin
- :module-level-form …))))
-
-(define-syntax-class general-top-level-form
- #:literals (define-values define-syntaxes #%require)
- (pattern :expr)
- (pattern (define-values (:id …) :expr))
- (pattern (define-syntaxes (:id …) :expr))
- (pattern (#%require _raw-require-spec …)))
-
-(define-syntax-class expr
- #:literals (lambda case-lambda if begin begin0
- let-values letrec-values letrec-syntaxes+values
- set! quote quote-syntax
- with-continuation-mark
- #%app #%top #%expression #%variable-reference
- define-values)
- (pattern :id)
- (pattern (lambda :formals :expr …+))
- (pattern (case-lambda (:formals :expr …+) …))
- (pattern (if :expr :expr :expr))
- (pattern (begin :expr …+))
- (pattern (begin0 :expr :expr …))
- (pattern (let-values ([(:acc-id …) :expr] …)
- :expr …+))
- (pattern (letrec-values ([(:acc-id …) :expr] …)
- :expr …+))
- (pattern (letrec-syntaxes+values ([(:acc-id …) :expr] …)
- ([(:acc-id …) :expr] …)
- :expr …+))
- (pattern (set! :id :expr))
- (pattern (quote _datum))
- (pattern (quote-syntax _datum))
- (pattern (quote-syntax _datum #:local))
- (pattern (with-continuation-mark :expr :expr :expr))
- (pattern (#%app :expr …+))
- (pattern (#%top . :id))
- (pattern (#%expression :expr))
- (pattern (#%variable-reference :id))
- (pattern (#%variable-reference (#%top . :id)))
- (pattern (#%variable-reference))
- (pattern (define-values (lifted-id:acc-id …) _lifted-expr)))
-
-(define-syntax-class formals
- (pattern (:acc-id …))
- (pattern (:acc-id …+ . :acc-id))
- (pattern :acc-id))
diff --git a/fully-expanded-grammar.rkt b/fully-expanded-grammar.rkt
@@ -1,90 +0,0 @@
-#lang racket/base
-
-;; This file is not used by the project, but can be used as a base for macros
-;; which need to parse the result of local-expand. For example, the file
-;; fully-expanded-grammar-extract-bindings.rkt is based on this one.
-
-(require syntax/parse
- phc-toolkit/untyped
- (for-template '#%kernel))
-
-(provide top-level-form
- module-level-form
- submodule-form
- general-top-level-form
- expr
- formals)
-
-(define-syntax-class top-level-form
- #:literals (#%expression module #%plain-module-begin begin begin-for-syntax)
- (pattern :general-top-level-form)
- (pattern (#%expression :expr))
- (pattern (module :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (begin :top-level-form …))
- (pattern (begin-for-syntax :top-level-form …)))
-
-(define-syntax-class module-level-form
- #:literals (#%provide begin-for-syntax #%declare)
- (pattern :general-top-level-form)
- (pattern (#%provide _raw-provide-spec …))
- (pattern (begin-for-syntax :module-level-form …))
- (pattern :submodule-form)
- (pattern (#%declare _declaration-keyword …)))
-
-(define-syntax-class submodule-form
- #:literals (module #%plain-module-begin module* )
- (pattern (module :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (module* :id _module-path
- (#%plain-module-begin
- :module-level-form …)))
- (pattern (module* :id #f
- (#%plain-module-begin
- :module-level-form …))))
-
-(define-syntax-class general-top-level-form
- #:literals (define-values define-syntaxes #%require)
- (pattern :expr)
- (pattern (define-values (:id …) :expr))
- (pattern (define-syntaxes (:id …) :expr))
- (pattern (#%require _raw-require-spec …)))
-
-(define-syntax-class expr
- #:literals (lambda case-lambda if begin begin0
- let-values letrec-values letrec-syntaxes+values
- set! quote quote-syntax
- with-continuation-mark
- #%app #%top #%expression #%variable-reference)
- (pattern :id)
- (pattern (lambda :formals :expr …+))
- (pattern (case-lambda (:formals :expr …+) …))
- (pattern (if :expr :expr :expr))
- (pattern (begin :expr …+))
- (pattern (begin0 :expr :expr …))
-
- (pattern (let-values ([(:id …) :expr] …)
- :expr …+))
- (pattern (letrec-values ([(:id …) :expr] …)
- :expr …+))
- (pattern (letrec-syntaxes+values ([(:id …) :expr] …)
- ([(:id …) :expr] …)
- :expr …+))
- (pattern (set! :id :expr))
- (pattern (quote _datum))
- (pattern (quote-syntax _datum))
- (pattern (quote-syntax _datum #:local))
- (pattern (with-continuation-mark :expr :expr :expr))
- (pattern (#%app :expr …+))
- (pattern (#%top . :id))
- (pattern (#%expression :expr))
- (pattern (#%variable-reference :id))
- (pattern (#%variable-reference (#%top . :id)))
- (pattern (#%variable-reference)))
-
-(define-syntax-class formals
- (pattern (:id …))
- (pattern (:id …+ . :id))
- (pattern :id))
-\ No newline at end of file
diff --git a/graph-type.hl.rkt b/graph-type.hl.rkt
@@ -129,12 +129,9 @@ the node types. It then binds the given @racket[name] to the
(for-syntax "graph-info.hl.rkt"
type-expander/expander
phc-toolkit/untyped
- (subtract-in syntax/parse phc-graph/subtemplate)
racket/set
- phc-graph/subtemplate-override
- racket/syntax
- extensible-parser-specifications
- backport-template-pr1514/experimental/template)
+ subtemplate/override
+ extensible-parser-specifications)
(for-meta 2 racket/base))
(provide define-graph-type)
diff --git a/graph.hl.rkt b/graph.hl.rkt
@@ -107,12 +107,11 @@ initial elements to enqueue, and processes the queues till they are all empty.
@chunk[<*>
(require racket/require
- (for-syntax (subtract-in (combine-in racket/base
- syntax/parse)
- "subtemplate-override.rkt")
+ (for-syntax (subtract-in racket/base
+ subtemplate/override)
phc-toolkit/untyped
type-expander/expander
- "subtemplate-override.rkt")
+ subtemplate/override)
"traversal.hl.rkt"
phc-toolkit)
<define-index>
diff --git a/info.rkt b/info.rkt
@@ -15,7 +15,9 @@
"scribble-lib"
"pconvert-lib"
"remember"
- "extensible-parser-specifications"))
+ "extensible-parser-specifications"
+ "subtemplate"
+ "stxparse-info"))
(define build-deps '("scribble-lib"
"racket-doc"
"remember"
diff --git a/patch-arrows.rkt b/patch-arrows.rkt
@@ -1,115 +0,0 @@
-#lang racket
-
-(require (for-template (only-in '#%kernel [module* k:module*])
- '#%kernel)
- phc-toolkit/untyped
- syntax/parse
- racket/syntax
- racket/list
- racket/contract
- syntax/id-table
- syntax/strip-context
- "fully-expanded-grammar-extract-bindings.rkt")
-
-(provide patch-arrows)
-
-
-(define/contract (patch-arrows stx)
- (-> syntax? syntax?)
- (define fully-expanded
- ;; TODO: local-expand/capture-lifts is probably not what we want here,
- ;; instead we should just let the lifted expressions pass through.
- (local-expand/capture-lifts stx 'expression (list #'k:module*))
- #;(local-expand stx 'expression (list #'k:module*)))
- (define extracted-list (extract-bindings fully-expanded))
- (define bindings-table (make-immutable-free-id-table (map cons
- extracted-list
- extracted-list)))
- (define patched-acc '())
-
- (define/contract (patch-srcloc id)
- (-> identifier? (or/c #f identifier?))
- (define table-ref (free-id-table-ref bindings-table id #f))
- (if (and table-ref
- ;; all info missing, i.e. (datum->syntax #'lctx 'sym #f) was used
- (not (or (syntax-source id)
- (syntax-position id)
- (syntax-line id)
- (syntax-column id))))
- (datum->syntax id (syntax-e id) table-ref id)
- #f))
-
- (fold-syntax
- (λ (stx rec)
- (define maybe-patched-binders
- (for*/list ([p* (in-value (syntax-property stx 'sub-range-binders))]
- #:when p*
- [p (in-list (flatten p*))])
- (match p
- [(vector (? identifier? d) d-start d-len
- (? identifier? s) s-start s-len)
- (let ([patched-d (patch-srcloc d)]
- [patched-s (patch-srcloc s)])
- (and (or patched-d patched-s)
- (vector (or patched-d d) d-start d-len
- (or patched-s s) s-start s-len)))]
- [(vector (? identifier? d) d-start d-len d-x d-y
- (? identifier? s) s-start s-len s-x s-y)
- (let ([patched-d (patch-srcloc d)]
- [patched-s (patch-srcloc s)])
- (and (or patched-d patched-s)
- (vector (or patched-d d) d-start d-len d-x d-y
- (or patched-s s) s-start s-len s-x s-y)))]
- [other #| not a sub-range-binder |# #f])))
- (define patched-binders (filter identity maybe-patched-binders))
- (when (not (null? patched-binders))
- (set! patched-acc (cons patched-binders patched-acc)))
-
- (rec stx))
- fully-expanded)
-
- (define existing-property (or (syntax-property fully-expanded
- 'sub-range-binders)
- '()))
- (syntax-property fully-expanded
- 'sub-range-binders
- (cons patched-acc existing-property)))
-
-;Example usage:
-#;(module* test racket
- (require phc-toolkit/untyped)
- (require (for-syntax (submod "..")))
- (require (for-syntax phc-toolkit/untyped
- racket/syntax))
-
- (define-for-syntax saved (box #f))
-
- (define-syntax/case (foo y) ()
- (with-arrows
- (record-sub-range-binders! (vector #'y
- 1 1
- (datum->syntax #'y
- (unbox saved)
- #f)
- 1 1))
- (record-disappeared-uses #'y)
- #'(define y 1)))
-
- (define-syntax/case (bar body) ()
- (set-box! saved 'aa)
- (patch-arrows #'body))
-
-
- (bar
- (begin
- 'aa
- (let ([aa 1])
- (let ([aa 1])
- ;; The arrow is drawn from bb to the binding of aa above, thanks to
- ;; the fact that the srcloc is #f for the arrow's origin id. The
- ;; patch-arrows function detects that, and substitutes the
- ;; corresponding definition.
- ;;
- ;; Note that it correctly binds to the nearest let, not the outer aa.
- (foo bb)
- aa)))))
diff --git a/subtemplate-override.rkt b/subtemplate-override.rkt
@@ -1,5 +0,0 @@
-#lang racket
-(require (rename-in "subtemplate.rkt"
- [subtemplate syntax]
- [quasisubtemplate quasisyntax]))
-(provide (all-from-out "subtemplate.rkt"))
-\ No newline at end of file
diff --git a/subtemplate.rkt b/subtemplate.rkt
@@ -1,332 +0,0 @@
-#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
- syntax/id-table
- racket/syntax
- (for-syntax "patch-arrows.rkt"
- syntax/parse
- racket/private/sc
- racket/syntax
- racket/list
- racket/function
- phc-toolkit/untyped
- syntax/strip-context
- srfi/13
- (subtract-in racket/string srfi/13)
- 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
- 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))
-
-(begin-for-syntax
- (define/contract (split-colon sym)
- (-> symbol? (cons/c symbol? (listof symbol?)))
- (cons sym
- (map string->symbol
- (string-split (symbol->string sym)
- ":")))))
-
-(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)));)
-
-(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))
- (substring a
- (- (string-length a) suffix-length)))
-
- (define/contract (subscript-binder? bound binder)
- (-> identifier? identifier? (or/c #f string?))
- (and (syntax-pattern-variable?
- (syntax-local-value binder
- (thunk #f)))
- (let* ([bound-string (symbol->string (syntax-e bound))]
- [binder-string (symbol->string (syntax-e binder))]
- [suffix (string-suffix bound-string binder-string)]
- [subs (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]+$" suffix)])
- (and subs (car subs)))))
-
- (define/contract (extract-subscripts id)
- (-> identifier? string?)
- (car (regexp-match #px"[ₐₑₕᵢⱼₖₗₘₙₒₚᵣₛₜᵤᵥₓᵦᵧᵨᵩᵪ]*$"
- (symbol->string (syntax-e id)))))
-
- (define/contract (subscript-equal? bound binder)
- (-> identifier? identifier? (or/c #f string?))
- (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 (drop-subscripts id)
- (-> identifier? identifier?)
- (let* ([str (symbol->string (syntax-e id))]
- [sub (extract-subscripts id)]
- [new-str (substring str 0 (- (string-length str)
- (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-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 ([binders+info (find-subscript-binder2 #'id)])
- (when binders+info
- (set! acc (cons binders+info acc)))
- #'id)]
- [other (rec #'other)]))
- ;; process the syntax, extract the derived bindings into acc
- (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)))
- ;; 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] …)
- (remove-duplicates acc #:key car))
-
- #`(let ()
- (derive bound binders max-binders depth scope-depth)
- …
- (let ()
- ;; 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))
-(define-syntax quasisubtemplate (sub*template #'quasitemplate))
-
-
-
-(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-syntax/case (derive2 bound
- binders
- (max-binder0 . max-binders)
- stx-depth
- stx-scope-depth) ()
- (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" #'max-binder0 (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))
-
- ;; Draw arrows in DrRacket.
- (with-arrows
- (define subscripts (subscript-equal? #'bound #'max-binder0))
- (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))
- (record-sub-range-binders! (vector #'bound
- (- (string-length bound-id-str)
- (string-length subscripts))
- (string-length subscripts)
- max-binder
- (- (string-length binder-id-str)
- (string-length subscripts))
- (string-length subscripts))))
- #;(define binder0-id-str (identifier->string #'max-binder0))
- #;(record-sub-range-binders! (vector #'bound
- (- (string-length bound-id-str)
- (string-length subscripts))
- (string-length subscripts)
- #'max-binder0
- (- (string-length binder0-id-str)
- (string-length subscripts))
- (string-length subscripts)))
- ;; 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.
- #`(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)))))
diff --git a/test/adt-pre-declarations.rkt b/test/adt-pre-declarations.rkt
@@ -15,3 +15,4 @@
(remembered! tagged-structure (| House-incomplete| owner))
(remembered! tagged-structure (| Person-incomplete| name))
(remembered! tagged-structure (City name))
+(remembered! tagged-structure (t0 w))
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -1,585 +0,0 @@
-#lang racket
-(require "../subtemplate.rkt"
- phc-toolkit/untyped
- rackunit)
-
-#|
-(define-syntax (tst stx)
- (syntax-case stx ()
- [(_ tt)
- #`'#,(find-subscript-binder #'tt #f)]))
-
-(check-false (syntax-case #'(a b) ()
- [(_ x)
- (tst x)]))
-
-(check-equal? (syntax-parse
- #'(a b c)
- [(_ x yᵢ)
- (list (tst x)
- (tst wᵢ))])
- '(#f yᵢ))
-
-|#
-
-(check-equal? (syntax->datum (syntax-parse #'(a b c d)
- [(_ xⱼ zᵢ …)
- (subtemplate foo)]))
- 'foo)
-
-#;(let ()
- (syntax-parse #'a #;(syntax-parse #'(a b c d)
- [(_ xⱼ zᵢ …)
- (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
- (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
- [_ #;(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'x2)]))
-
-(syntax-parse (syntax-parse #'(a b c d)
- [(_ xⱼ zᵢ …)
- (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
- (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
- [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'x2)
- (check free-identifier=? #'w1 #'w2)
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
-
- (check free-identifier=? #'x1 #'b)
- (check free-identifier=? #'z1 #'c)
- (check free-identifier=? #'zz1 #'d)
-
- (check free-identifier=? #'x2 #'b)
- (check free-identifier=? #'z2 #'c)
- (check free-identifier=? #'zz2 #'d)
-
- ;; The *1 are all different:
- (check free-identifier=? #'x1 #'x1)
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'foo1)
- (check (∘ not free-identifier=?) #'x1 #'z1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'zz1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
-
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check free-identifier=? #'w1 #'w1)
- (check (∘ not free-identifier=?) #'w1 #'foo1)
- (check (∘ not free-identifier=?) #'w1 #'z1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'zz1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
-
- (check (∘ not free-identifier=?) #'foo1 #'x1)
- (check (∘ not free-identifier=?) #'foo1 #'w1)
- (check free-identifier=? #'foo1 #'foo1)
- (check (∘ not free-identifier=?) #'foo1 #'z1)
- (check (∘ not free-identifier=?) #'foo1 #'p1)
- (check (∘ not free-identifier=?) #'foo1 #'zz1)
- (check (∘ not free-identifier=?) #'foo1 #'pp1)
-
- (check (∘ not free-identifier=?) #'z1 #'x1)
- (check (∘ not free-identifier=?) #'z1 #'w1)
- (check (∘ not free-identifier=?) #'z1 #'foo1)
- (check free-identifier=? #'z1 #'z1)
- (check (∘ not free-identifier=?) #'z1 #'p1)
- (check (∘ not free-identifier=?) #'z1 #'zz1)
- (check (∘ not free-identifier=?) #'z1 #'pp1)
-
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'foo1)
- (check (∘ not free-identifier=?) #'p1 #'z1)
- (check free-identifier=? #'p1 #'p1)
- (check (∘ not free-identifier=?) #'p1 #'zz1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)
-
- (check (∘ not free-identifier=?) #'zz1 #'x1)
- (check (∘ not free-identifier=?) #'zz1 #'w1)
- (check (∘ not free-identifier=?) #'zz1 #'foo1)
- (check (∘ not free-identifier=?) #'zz1 #'z1)
- (check (∘ not free-identifier=?) #'zz1 #'p1)
- (check free-identifier=? #'zz1 #'zz1)
- (check (∘ not free-identifier=?) #'zz1 #'pp1)
-
- (check (∘ not free-identifier=?) #'pp1 #'x1)
- (check (∘ not free-identifier=?) #'pp1 #'w1)
- (check (∘ not free-identifier=?) #'pp1 #'foo1)
- (check (∘ not free-identifier=?) #'pp1 #'z1)
- (check (∘ not free-identifier=?) #'pp1 #'p1)
- (check (∘ not free-identifier=?) #'pp1 #'zz1)
- (check free-identifier=? #'pp1 #'pp1)
-
- ;; The *2 are all different:
- (check free-identifier=? #'x2 #'x2)
- (check (∘ not free-identifier=?) #'x2 #'w2)
- (check (∘ not free-identifier=?) #'x2 #'foo2)
- (check (∘ not free-identifier=?) #'x2 #'z2)
- (check (∘ not free-identifier=?) #'x2 #'p2)
- (check (∘ not free-identifier=?) #'x2 #'zz2)
- (check (∘ not free-identifier=?) #'x2 #'pp2)
-
- (check (∘ not free-identifier=?) #'w2 #'x2)
- (check free-identifier=? #'w2 #'w2)
- (check (∘ not free-identifier=?) #'w2 #'foo2)
- (check (∘ not free-identifier=?) #'w2 #'z2)
- (check (∘ not free-identifier=?) #'w2 #'p2)
- (check (∘ not free-identifier=?) #'w2 #'zz2)
- (check (∘ not free-identifier=?) #'w2 #'pp2)
-
- (check (∘ not free-identifier=?) #'foo2 #'x2)
- (check (∘ not free-identifier=?) #'foo2 #'w2)
- (check free-identifier=? #'foo2 #'foo2)
- (check (∘ not free-identifier=?) #'foo2 #'z2)
- (check (∘ not free-identifier=?) #'foo2 #'p2)
- (check (∘ not free-identifier=?) #'foo2 #'zz2)
- (check (∘ not free-identifier=?) #'foo2 #'pp2)
-
- (check (∘ not free-identifier=?) #'z2 #'x2)
- (check (∘ not free-identifier=?) #'z2 #'w2)
- (check (∘ not free-identifier=?) #'z2 #'foo2)
- (check free-identifier=? #'z2 #'z2)
- (check (∘ not free-identifier=?) #'z2 #'p2)
- (check (∘ not free-identifier=?) #'z2 #'zz2)
- (check (∘ not free-identifier=?) #'z2 #'pp2)
-
- (check (∘ not free-identifier=?) #'p2 #'x2)
- (check (∘ not free-identifier=?) #'p2 #'w2)
- (check (∘ not free-identifier=?) #'p2 #'foo2)
- (check (∘ not free-identifier=?) #'p2 #'z2)
- (check free-identifier=? #'p2 #'p2)
- (check (∘ not free-identifier=?) #'p2 #'zz2)
- (check (∘ not free-identifier=?) #'p2 #'pp2)
-
- (check (∘ not free-identifier=?) #'zz2 #'x2)
- (check (∘ not free-identifier=?) #'zz2 #'w2)
- (check (∘ not free-identifier=?) #'zz2 #'foo2)
- (check (∘ not free-identifier=?) #'zz2 #'z2)
- (check (∘ not free-identifier=?) #'zz2 #'p2)
- (check free-identifier=? #'zz2 #'zz2)
- (check (∘ not free-identifier=?) #'zz2 #'pp2)
-
- (check (∘ not free-identifier=?) #'pp2 #'x2)
- (check (∘ not free-identifier=?) #'pp2 #'w2)
- (check (∘ not free-identifier=?) #'pp2 #'foo2)
- (check (∘ not free-identifier=?) #'pp2 #'z2)
- (check (∘ not free-identifier=?) #'pp2 #'p2)
- (check (∘ not free-identifier=?) #'pp2 #'zz2)
- (check free-identifier=? #'pp2 #'pp2)])
-
-(syntax-parse (syntax-parse #'(a b c)
- [(xᵢ …)
- (define flob (quasisubtemplate (zᵢ …)))
- (quasisubtemplate (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ᵢ …
- #,(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ᵢ …)
- (define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
- (quasisubtemplate (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ᵢ …
- #,(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ᵢ …
- #,(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ᵢ …
- #,(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ᵢ …
- #,(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 (syntax-parse #'(a b c)
- [(xᵢ …)
- (quasisubtemplate (yᵢ …
- #,(syntax-parse #'d
- [zᵢ (quasisubtemplate (zᵢ))])
- #,(syntax-parse #'d
- [zᵢ (quasisubtemplate (zᵢ))])
- zᵢ …))])
- [(y yy yyy (d1) (d2) z zz zzz)
- (check free-identifier=? #'d1 #'d2)
-
- (check (∘ not free-identifier=?) #'y #'yy)
- (check (∘ not free-identifier=?) #'y #'yyy)
- (check (∘ not free-identifier=?) #'y #'d1)
- (check (∘ not free-identifier=?) #'y #'d2)
- (check (∘ not free-identifier=?) #'y #'z)
- (check (∘ not free-identifier=?) #'y #'zz)
- (check (∘ not free-identifier=?) #'y #'zzz)
-
- (check (∘ not free-identifier=?) #'yy #'y)
- (check (∘ not free-identifier=?) #'yy #'yyy)
- (check (∘ not free-identifier=?) #'yy #'d1)
- (check (∘ not free-identifier=?) #'yy #'d2)
- (check (∘ not free-identifier=?) #'yy #'z)
- (check (∘ not free-identifier=?) #'yy #'zz)
- (check (∘ not free-identifier=?) #'yy #'zzz)
-
- (check (∘ not free-identifier=?) #'yyy #'y)
- (check (∘ not free-identifier=?) #'yyy #'yy)
- (check (∘ not free-identifier=?) #'yyy #'d1)
- (check (∘ not free-identifier=?) #'yyy #'d2)
- (check (∘ not free-identifier=?) #'yyy #'z)
- (check (∘ not free-identifier=?) #'yyy #'zz)
- (check (∘ not free-identifier=?) #'yyy #'zzz)
-
- (check (∘ not free-identifier=?) #'d1 #'y)
- (check (∘ not free-identifier=?) #'d1 #'yy)
- (check (∘ not free-identifier=?) #'d1 #'yyy)
- ;(check (∘ not free-identifier=?) #'d1 #'d2)
- (check (∘ not free-identifier=?) #'d1 #'z)
- (check (∘ not free-identifier=?) #'d1 #'zz)
- (check (∘ not free-identifier=?) #'d1 #'zzz)
-
- (check (∘ not free-identifier=?) #'d2 #'y)
- (check (∘ not free-identifier=?) #'d2 #'yy)
- (check (∘ not free-identifier=?) #'d2 #'yyy)
- ;(check (∘ not free-identifier=?) #'d2 #'d1)
- (check (∘ not free-identifier=?) #'d2 #'z)
- (check (∘ not free-identifier=?) #'d2 #'zz)
- (check (∘ not free-identifier=?) #'d2 #'zzz)
-
- (check (∘ not free-identifier=?) #'z #'y)
- (check (∘ not free-identifier=?) #'z #'yy)
- (check (∘ not free-identifier=?) #'z #'yyy)
- (check (∘ not free-identifier=?) #'z #'d1)
- (check (∘ not free-identifier=?) #'z #'d2)
- (check (∘ not free-identifier=?) #'z #'zz)
- (check (∘ not free-identifier=?) #'z #'zzz)
-
- (check (∘ not free-identifier=?) #'zz #'y)
- (check (∘ not free-identifier=?) #'zz #'yy)
- (check (∘ not free-identifier=?) #'zz #'yyy)
- (check (∘ not free-identifier=?) #'zz #'d1)
- (check (∘ not free-identifier=?) #'zz #'d2)
- (check (∘ not free-identifier=?) #'zz #'z)
- (check (∘ not free-identifier=?) #'zz #'zzz)
-
- (check (∘ not free-identifier=?) #'zzz #'y)
- (check (∘ not free-identifier=?) #'zzz #'yy)
- (check (∘ not free-identifier=?) #'zzz #'yyy)
- (check (∘ not free-identifier=?) #'zzz #'d1)
- (check (∘ not free-identifier=?) #'zzz #'d2)
- (check (∘ not free-identifier=?) #'zzz #'z)
- (check (∘ not free-identifier=?) #'zzz #'zz)])
-
-(syntax-parse (syntax-parse #'(a b c d)
- [(_ xⱼ zᵢ …)
- (list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
- (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
- [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'b)
- (check free-identifier=? #'foo1 #'foo)
- (check free-identifier=? #'z1 #'c)
- (check free-identifier=? #'zz1 #'d)
-
- (check free-identifier=? #'x2 #'b)
- (check free-identifier=? #'foo2 #'foo)
- (check free-identifier=? #'z2 #'c)
- (check free-identifier=? #'zz2 #'d)
-
- (check free-identifier=? #'x1 #'x2)
- (check free-identifier=? #'w1 #'w2)
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
-
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)])
-
-(syntax-parse (syntax-parse #'()
- [()
- (syntax-parse #'(a b)
- [(zᵢ …)
- (list (syntax-parse #'(e)
- [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
- (syntax-parse #'(e) ;; TODO: same test with f
- [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])
- [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'e)
- (check free-identifier=? #'foo1 #'foo)
- (check free-identifier=? #'z1 #'a)
- (check free-identifier=? #'zz1 #'b)
-
- (check free-identifier=? #'x2 #'e)
- (check free-identifier=? #'foo2 #'foo)
- (check free-identifier=? #'z2 #'a)
- (check free-identifier=? #'zz2 #'b)
-
- (check free-identifier=? #'x1 #'x2)
- (check (∘ not free-identifier=?) #'w1 #'w2) ;; yes above, no here.
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
-
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)])
-
-(syntax-parse (syntax-parse #'()
- [()
- (syntax-parse #'(a b)
- [(zᵢ …)
- (list (syntax-parse #'(e)
- [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
- (syntax-parse #'(f) ;; above: was e, not f
- [(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])
- [(([x1 w1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'e)
- (check free-identifier=? #'foo1 #'foo)
- (check free-identifier=? #'z1 #'a)
- (check free-identifier=? #'zz1 #'b)
-
- (check free-identifier=? #'x2 #'f) ;; above: was e, not f
- (check free-identifier=? #'foo2 #'foo)
- (check free-identifier=? #'z2 #'a)
- (check free-identifier=? #'zz2 #'b)
-
- (check (∘ not free-identifier=?) #'x1 #'x2) ;; yes above, no here.
- (check (∘ not free-identifier=?) #'w1 #'w2) ;; yes above above, no here.
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
-
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)])
-
-(syntax-parse (syntax-parse #'()
- [()
- (syntax-parse #'(a b)
- [(zᵢ …)
- (list (syntax-parse #'(c d)
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
- (syntax-parse #'(cc dd)
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])
- [(([x1 w1] [xx1 ww1] foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] [xx2 ww2] foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'c)
- (check free-identifier=? #'xx1 #'d)
- (check free-identifier=? #'foo1 #'foo)
- (check free-identifier=? #'z1 #'a)
- (check free-identifier=? #'zz1 #'b)
-
- (check free-identifier=? #'x2 #'cc)
- (check free-identifier=? #'xx2 #'dd)
- (check free-identifier=? #'foo2 #'foo)
- (check free-identifier=? #'z2 #'a)
- (check free-identifier=? #'zz2 #'b)
-
- (check (∘ not free-identifier=?) #'x1 #'x2)
- (check (∘ not free-identifier=?) #'xx1 #'xx2)
- (check free-identifier=? #'w1 #'w2)
- (check free-identifier=? #'ww1 #'ww2)
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)
-
- (check (∘ not free-identifier=?) #'x1 #'xx1)
- (check (∘ not free-identifier=?) #'x1 #'w1)
- (check (∘ not free-identifier=?) #'x1 #'p1)
- (check (∘ not free-identifier=?) #'x1 #'pp1)
- (check (∘ not free-identifier=?) #'xx1 #'x1)
- (check (∘ not free-identifier=?) #'xx1 #'w1)
- (check (∘ not free-identifier=?) #'xx1 #'p1)
- (check (∘ not free-identifier=?) #'xx1 #'pp1)
- (check (∘ not free-identifier=?) #'w1 #'xx1)
- (check (∘ not free-identifier=?) #'w1 #'x1)
- (check (∘ not free-identifier=?) #'w1 #'p1)
- (check (∘ not free-identifier=?) #'w1 #'pp1)
- (check (∘ not free-identifier=?) #'p1 #'xx1)
- (check (∘ not free-identifier=?) #'p1 #'x1)
- (check (∘ not free-identifier=?) #'p1 #'w1)
- (check (∘ not free-identifier=?) #'p1 #'pp1)])
-
-(check-exn #px"incompatible ellipsis match counts for template"
- (λ ()
- (syntax-parse #'()
- [()
- (syntax-parse #'(a b)
- [(zᵢ …)
- (list (syntax-parse #'(c) ;; one here, two above and below
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
- (syntax-parse #'(cc dd)
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
-
-;; Test for arrows, with two maximal candidates tᵢ and zᵢ :
-;; the arrow should be drawn to the ᵢ in wᵢ and pᵢ from the ᵢ in the bindings
-;; for both tᵢ and zᵢ. For the uses of xᵢ, tᵢ and zᵢ, there should be only one
-;; arrow, drawn from the correponding binding.
-(syntax-parse (syntax-parse #'()
- [()
- (syntax-parse #'([a b] [aa bb])
- [([tᵢ …] [zᵢ …])
- (list (syntax-parse #'(c d)
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))])
- (syntax-parse #'(cc dd)
- [(xᵢ …)
- (subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))]))])])
- [(([x1 w1] [xx1 ww1] t1 tt1 foo1 [z1 p1] [zz1 pp1])
- ([x2 w2] [xx2 ww2] t2 tt2 foo2 [z2 p2] [zz2 pp2]))
- (check free-identifier=? #'x1 #'c)
- (check free-identifier=? #'xx1 #'d)
- (check free-identifier=? #'x2 #'cc)
- (check free-identifier=? #'xx2 #'dd)
-
- (check free-identifier=? #'t1 #'a)
- (check free-identifier=? #'tt1 #'b)
- (check free-identifier=? #'t2 #'a)
- (check free-identifier=? #'tt2 #'b)
-
- (check (∘ not free-identifier=?) #'x1 #'x2)
- (check free-identifier=? #'w1 #'w2)
- (check (∘ not free-identifier=?) #'xx1 #'xx2)
- (check free-identifier=? #'ww1 #'ww2)
- (check free-identifier=? #'t1 #'t2)
- (check free-identifier=? #'tt1 #'tt2)
- (check free-identifier=? #'foo1 #'foo2)
- (check free-identifier=? #'z1 #'z2)
- (check free-identifier=? #'p1 #'p2)
- (check free-identifier=? #'zz1 #'zz2)
- (check free-identifier=? #'pp1 #'pp2)])
diff --git a/test/test-traversal-2.rkt b/test/test-traversal-2.rkt
@@ -7,6 +7,8 @@
"../dispatch-union.rkt") ;; DEBUG
(adt-init)
+
+
(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
(define-fold f₂ t₂ (U (tagged tg [a String] [b Boolean])) String)
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
diff --git a/test/traversal-util.rkt b/test/traversal-util.rkt
@@ -1,6 +1,6 @@
#lang typed/racket
-(require (for-syntax syntax/parse
- backport-template-pr1514/experimental/template
+(require (for-syntax stxparse-info/parse
+ stxparse-info/parse/experimental/template
type-expander/expander)
"../traversal.hl.rkt")
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -227,7 +227,8 @@ not expressed syntactically using the @racket[Foo] identifier.
#`[(λ ({?@ _predicateᵢ _updateᵢ} …)
(λ (v acc)
#,(syntax-parse #'_whole-type
- #:literals (Null Pairof Listof List Vectorof Vector U tagged)
+ #:literals (Null Pairof Listof List
+ Vectorof Vector U tagged)
<f-cases>)))
(∀ (_Aᵢ … _Bᵢ … Acc)
(→ (?@ (→ Any Boolean : _Aᵢ)
@@ -369,13 +370,10 @@ where @racket[foldl-map] is defined as:
type-expander
phc-adt
"dispatch-union.rkt"
- (for-syntax "subtemplate-override.rkt"
- (subtract-in (combine-in racket/base
- syntax/parse)
- "subtemplate-override.rkt")
- backport-template-pr1514/experimental/template
+ (for-syntax (subtract-in racket/base
+ subtemplate/override)
+ subtemplate/override
phc-toolkit/untyped
- racket/syntax
type-expander/expander
"free-identifier-tree-equal.rkt"
racket/dict)
