Closes FB case 189 Switch phc-graph to the packaged subtemplate
This commit is contained in:
Georges Dupéron
parent
39e703b127
commit
8bf2315281
|
|
@ -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))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
4
info.rkt
4
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"
|
||||
|
|
|
|||
115
patch-arrows.rkt
115
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)))))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
(require (rename-in "subtemplate.rkt"
|
||||
[subtemplate syntax]
|
||||
[quasisubtemplate quasisyntax]))
|
||||
(provide (all-from-out "subtemplate.rkt"))
|
||||
332
subtemplate.rkt
332
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)))))
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user