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"
|
(for-syntax "graph-info.hl.rkt"
|
||||||
type-expander/expander
|
type-expander/expander
|
||||||
phc-toolkit/untyped
|
phc-toolkit/untyped
|
||||||
(subtract-in syntax/parse phc-graph/subtemplate)
|
|
||||||
racket/set
|
racket/set
|
||||||
phc-graph/subtemplate-override
|
subtemplate/override
|
||||||
racket/syntax
|
extensible-parser-specifications)
|
||||||
extensible-parser-specifications
|
|
||||||
backport-template-pr1514/experimental/template)
|
|
||||||
(for-meta 2 racket/base))
|
(for-meta 2 racket/base))
|
||||||
|
|
||||||
(provide define-graph-type)
|
(provide define-graph-type)
|
||||||
|
|
|
||||||
|
|
@ -107,12 +107,11 @@ initial elements to enqueue, and processes the queues till they are all empty.
|
||||||
|
|
||||||
@chunk[<*>
|
@chunk[<*>
|
||||||
(require racket/require
|
(require racket/require
|
||||||
(for-syntax (subtract-in (combine-in racket/base
|
(for-syntax (subtract-in racket/base
|
||||||
syntax/parse)
|
subtemplate/override)
|
||||||
"subtemplate-override.rkt")
|
|
||||||
phc-toolkit/untyped
|
phc-toolkit/untyped
|
||||||
type-expander/expander
|
type-expander/expander
|
||||||
"subtemplate-override.rkt")
|
subtemplate/override)
|
||||||
"traversal.hl.rkt"
|
"traversal.hl.rkt"
|
||||||
phc-toolkit)
|
phc-toolkit)
|
||||||
<define-index>
|
<define-index>
|
||||||
|
|
|
||||||
4
info.rkt
4
info.rkt
|
|
@ -15,7 +15,9 @@
|
||||||
"scribble-lib"
|
"scribble-lib"
|
||||||
"pconvert-lib"
|
"pconvert-lib"
|
||||||
"remember"
|
"remember"
|
||||||
"extensible-parser-specifications"))
|
"extensible-parser-specifications"
|
||||||
|
"subtemplate"
|
||||||
|
"stxparse-info"))
|
||||||
(define build-deps '("scribble-lib"
|
(define build-deps '("scribble-lib"
|
||||||
"racket-doc"
|
"racket-doc"
|
||||||
"remember"
|
"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 (| House-incomplete| owner))
|
||||||
(remembered! tagged-structure (| Person-incomplete| name))
|
(remembered! tagged-structure (| Person-incomplete| name))
|
||||||
(remembered! tagged-structure (City 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
|
"../dispatch-union.rkt") ;; DEBUG
|
||||||
(adt-init)
|
(adt-init)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-fold f₁ t₁ (tagged tg [a String] [b Boolean]) String)
|
(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])) String)
|
||||||
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
|
(define-fold f₃ t₃ (U (tagged tg [a String] [b Boolean])
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
#lang typed/racket
|
#lang typed/racket
|
||||||
(require (for-syntax syntax/parse
|
(require (for-syntax stxparse-info/parse
|
||||||
backport-template-pr1514/experimental/template
|
stxparse-info/parse/experimental/template
|
||||||
type-expander/expander)
|
type-expander/expander)
|
||||||
"../traversal.hl.rkt")
|
"../traversal.hl.rkt")
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -227,7 +227,8 @@ not expressed syntactically using the @racket[Foo] identifier.
|
||||||
#`[(λ ({?@ _predicateᵢ _updateᵢ} …)
|
#`[(λ ({?@ _predicateᵢ _updateᵢ} …)
|
||||||
(λ (v acc)
|
(λ (v acc)
|
||||||
#,(syntax-parse #'_whole-type
|
#,(syntax-parse #'_whole-type
|
||||||
#:literals (Null Pairof Listof List Vectorof Vector U tagged)
|
#:literals (Null Pairof Listof List
|
||||||
|
Vectorof Vector U tagged)
|
||||||
<f-cases>)))
|
<f-cases>)))
|
||||||
(∀ (_Aᵢ … _Bᵢ … Acc)
|
(∀ (_Aᵢ … _Bᵢ … Acc)
|
||||||
(→ (?@ (→ Any Boolean : _Aᵢ)
|
(→ (?@ (→ Any Boolean : _Aᵢ)
|
||||||
|
|
@ -369,13 +370,10 @@ where @racket[foldl-map] is defined as:
|
||||||
type-expander
|
type-expander
|
||||||
phc-adt
|
phc-adt
|
||||||
"dispatch-union.rkt"
|
"dispatch-union.rkt"
|
||||||
(for-syntax "subtemplate-override.rkt"
|
(for-syntax (subtract-in racket/base
|
||||||
(subtract-in (combine-in racket/base
|
subtemplate/override)
|
||||||
syntax/parse)
|
subtemplate/override
|
||||||
"subtemplate-override.rkt")
|
|
||||||
backport-template-pr1514/experimental/template
|
|
||||||
phc-toolkit/untyped
|
phc-toolkit/untyped
|
||||||
racket/syntax
|
|
||||||
type-expander/expander
|
type-expander/expander
|
||||||
"free-identifier-tree-equal.rkt"
|
"free-identifier-tree-equal.rkt"
|
||||||
racket/dict)
|
racket/dict)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user