Arrows for subtemplate derived ids work in DrRacket
This commit is contained in:
Georges Dupéron
parent
60e567af3b
commit
9f738e12e5
109
fully-expanded-grammar-extract-bindings.rkt
Normal file
109
fully-expanded-grammar-extract-bindings.rkt
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
#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))
|
||||
90
fully-expanded-grammar.rkt
Normal file
90
fully-expanded-grammar.rkt
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
#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 (#%plain-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 (#%plain-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))
|
||||
115
patch-arrows.rkt
Normal file
115
patch-arrows.rkt
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
#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)))))
|
||||
215
subtemplate.rkt
215
subtemplate.rkt
|
|
@ -1,11 +1,13 @@
|
|||
#lang racket
|
||||
(require phc-toolkit/untyped
|
||||
(require racket/require
|
||||
phc-toolkit/untyped
|
||||
racket/stxparam
|
||||
syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
syntax/id-table
|
||||
racket/syntax
|
||||
(for-syntax syntax/parse
|
||||
(for-syntax "patch-arrows.rkt"
|
||||
syntax/parse
|
||||
racket/private/sc
|
||||
racket/syntax
|
||||
racket/list
|
||||
|
|
@ -13,10 +15,12 @@
|
|||
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])
|
||||
subtemplate
|
||||
quasisubtemplate)
|
||||
|
|
@ -27,6 +31,14 @@
|
|||
(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?)))
|
||||
|
|
@ -37,38 +49,48 @@
|
|||
'#,(~> (syntax->datum rest)
|
||||
flatten
|
||||
(filter symbol? _)
|
||||
(append-map split-colon _)
|
||||
(remove-duplicates)))
|
||||
(syntax-parameter-value
|
||||
#'maybe-syntax-pattern-variable-ids)));)
|
||||
|
||||
(define-syntax/parse (new-syntax-parse . rest)
|
||||
(quasisyntax/top-loc (stx-car stx)
|
||||
;; 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 (stx-car stx))]
|
||||
[pvar-values-id (make-rename-transformer
|
||||
#'the-pvar-values)])
|
||||
(syntax-parse . rest)))))
|
||||
(begin-for-syntax
|
||||
(define/contract (wrap-with-parameterize lctx new-whole-form rest)
|
||||
(-> identifier? syntax? syntax? syntax?)
|
||||
(patch-arrows
|
||||
(quasisyntax/top-loc lctx
|
||||
;; 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))))))
|
||||
|
||||
(define-syntax/case (new-syntax-case . rest) ()
|
||||
(error "new-syntax-case not implemented yet")
|
||||
#;(quasisyntax/top-loc (stx-car stx)
|
||||
(let ([the-pvar-values (or pvar-values-id (make-free-id-table))])
|
||||
(syntax-parameterize ([maybe-syntax-pattern-variable-ids
|
||||
(cons '#,(remove-duplicates
|
||||
(filter symbol?
|
||||
(flatten
|
||||
(syntax->datum #'rest))))
|
||||
(syntax-parameter-value
|
||||
#'maybe-syntax-pattern-variable-ids))]
|
||||
[pvar-values-id (make-rename-transformer
|
||||
#'the-pvar-values)])
|
||||
(syntax-case . rest)))))
|
||||
(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)
|
||||
|
|
@ -118,18 +140,7 @@
|
|||
(add1 scope-depth)))
|
||||
(define found-here
|
||||
(for*/list ([binder-sym (in-list syms)]
|
||||
[binder (in-value (datum->syntax lctx binder-sym))]
|
||||
#;#:when #;(displayln (list bound binder
|
||||
'pvar?= (syntax-pattern-variable?
|
||||
(syntax-local-value binder (thunk #f)))
|
||||
'derived?= (derived?
|
||||
(syntax-local-value
|
||||
(format-id binder
|
||||
" is-derived-~a "
|
||||
binder)
|
||||
(thunk #f)))
|
||||
(subscript-equal? bound
|
||||
binder)))
|
||||
[binder (in-value (datum->syntax lctx binder-sym #f))]
|
||||
#:when (syntax-pattern-variable?
|
||||
(syntax-local-value binder (thunk #f)))
|
||||
#:when (not (derived?
|
||||
|
|
@ -141,9 +152,7 @@
|
|||
[subscripts (in-value (subscript-equal? bound
|
||||
binder))]
|
||||
#:when subscripts)
|
||||
;(displayln (list binder scope-depth))
|
||||
(list binder scope-depth)))
|
||||
;(displayln (list* 'found-here= bound '→ found-here))
|
||||
(if (null? found-here)
|
||||
recur-found
|
||||
(append found-here recur-found)))))
|
||||
|
|
@ -151,7 +160,8 @@
|
|||
(define/contract (find-subscript-binder2 bound)
|
||||
(-> identifier?
|
||||
(or/c #f (list/c identifier? ;; bound
|
||||
(syntax/c (listof identifier?)) ;; bindings
|
||||
(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
|
||||
|
|
@ -161,7 +171,6 @@
|
|||
scopes
|
||||
bound
|
||||
0))
|
||||
;(displayln (syntax->datum #`(2 bound= #,bound 2a-result= [binder scope-depth] …)))
|
||||
(if (stx-null? #'(binder …))
|
||||
#f
|
||||
(let ()
|
||||
|
|
@ -176,10 +185,18 @@
|
|||
;; 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)
|
||||
(apply max (syntax->datum #'(scope-depth …)))
|
||||
max-scope-depth
|
||||
#'check-ellipsis-count-ddd))))
|
||||
|
||||
(define/contract (nest-ellipses stx n)
|
||||
|
|
@ -197,10 +214,9 @@
|
|||
(free-identifier=? #'id #'unsyntax))
|
||||
stx]
|
||||
[id (identifier? #'id)
|
||||
(let ([binders (find-subscript-binder2 #'id)])
|
||||
(when binders
|
||||
;(displayln (syntax->datum (datum->syntax #f binders)))
|
||||
(set! acc (cons binders acc)))
|
||||
(let ([binders+info (find-subscript-binder2 #'id)])
|
||||
(when binders+info
|
||||
(set! acc (cons binders+info acc)))
|
||||
#'id)]
|
||||
[other (rec #'other)]))
|
||||
(define result
|
||||
|
|
@ -210,17 +226,15 @@
|
|||
#'tmpl))))
|
||||
;; Make sure that we remove duplicates, otherwise we'll get errors if we
|
||||
;; define the same derived id twice.
|
||||
(define/with-syntax ([bound (binder0 . binders)
|
||||
(define/with-syntax ([bound binders
|
||||
max-binders
|
||||
depth
|
||||
scope-depth
|
||||
check-ellipsis-count] …)
|
||||
(remove-duplicates acc #:key car))
|
||||
|
||||
#;(displayln (syntax->datum #'((derive2 bound binder0 (binder0 . binders) depth scope-depth)
|
||||
…)))
|
||||
|
||||
#`(let ()
|
||||
(derive2 bound binder0 (binder0 . binders) depth scope-depth)
|
||||
(derive bound binders max-binders depth scope-depth)
|
||||
…
|
||||
(let ()
|
||||
;; no-op, just to raise an error when they are incompatible
|
||||
|
|
@ -233,42 +247,67 @@
|
|||
|
||||
|
||||
|
||||
(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 binder0 binders stx-depth stx-scope-depth) ()
|
||||
(define/with-syntax bound-def #'bound #;(replace-context #'binder0 #'bound))
|
||||
(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-def depth))
|
||||
(define/with-syntax tmp-id (format-id #'here "~a/~a" #'binder0 #'bound-def))
|
||||
(define/with-syntax bound-ddd (nest-ellipses #'bound depth))
|
||||
(define/with-syntax tmp-id (format-id #'here "~a/~a" #'max-binder0 #'bound))
|
||||
(define/with-syntax tmp-str (datum->syntax #'tmp-id (symbol->string
|
||||
(syntax-e #'tmp-id))))
|
||||
(define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth))
|
||||
(define/with-syntax binder-ddd (nest-ellipses (replace-context #'bound #'binder0) ;; why oh why do I need replace-context here???
|
||||
depth))
|
||||
;; HERE: cache the define-temp-ids in the free-id-table, and make sure
|
||||
;; that we retrieve the cached ones, so that two subtemplate within the same
|
||||
;; syntax-case or syntax-parse clause use the same derived ids.
|
||||
;; TODO: mark specially those bindings bound by (derive …) so that they are
|
||||
;; not seen as original bindings in nested subtemplates (e.g. with an
|
||||
;; "unsyntax"), otherwise that rule may not hold anymore, e.g.
|
||||
;; (syntax-parse #'(a b c)
|
||||
;; [(xᵢ …)
|
||||
;; (quasisubtemplate (yᵢ …
|
||||
;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ
|
||||
;; zᵢ …))])
|
||||
;; the test above is not exactly right (zᵢ will still have the correct
|
||||
;; binding), but it gives the general idea.
|
||||
(define/with-syntax binder-ddd (nest-ellipses #'max-binder0 depth))
|
||||
|
||||
;; TODO: shouldn't be called in the first place? ;; TODO: remove?
|
||||
(if (syntax-pattern-variable? (syntax-local-value #'bound (thunk #f)))
|
||||
#'(begin)
|
||||
#`(begin (define-temp-ids tmp-str binder-ddd)
|
||||
(define cached (hash-ref! (list-ref pvar-values-id
|
||||
stx-scope-depth)
|
||||
'bound-def
|
||||
#'tmp-ddd))
|
||||
(define/with-syntax bound-ddd cached)
|
||||
(define-syntax #,(format-id #'bound
|
||||
" is-derived-~a "
|
||||
#'bound)
|
||||
(derived)))))
|
||||
;; 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)))))
|
||||
|
|
@ -27,141 +27,150 @@
|
|||
(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)
|
||||
[(_ 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=? #'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)
|
||||
(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)
|
||||
;; 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=?) #'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=?) #'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=?) #'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=?) #'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=?) #'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)
|
||||
(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)
|
||||
;; 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=?) #'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=?) #'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=?) #'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=?) #'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=?) #'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)])
|
||||
(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ᵢ …)
|
||||
|
|
@ -289,13 +298,13 @@
|
|||
wᵢ …))]))
|
||||
|
||||
(syntax-parse (syntax-parse #'(a b c)
|
||||
[(xᵢ …)
|
||||
(quasisubtemplate (yᵢ …
|
||||
#,(syntax-parse #'d
|
||||
[zᵢ (quasisubtemplate (zᵢ))])
|
||||
#,(syntax-parse #'d
|
||||
[zᵢ (quasisubtemplate (zᵢ))])
|
||||
zᵢ …))])
|
||||
[(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)
|
||||
|
||||
|
|
@ -535,4 +544,17 @@
|
|||
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
|
||||
(syntax-parse #'(cc dd)
|
||||
[(xᵢ …)
|
||||
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
|
||||
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
|
||||
|
||||
;; Test for arrows, with two maximal candidates tᵢ and zᵢ :
|
||||
(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ᵢ] …))]))])])
|
||||
[_ 'TODO])
|
||||
|
|
|
|||
|
|
@ -134,18 +134,35 @@ way up, so that a simple identity function can be applied in these cases.
|
|||
(local-require racket/pretty)
|
||||
#;(pretty-write (syntax->datum x))
|
||||
x)
|
||||
(template
|
||||
(subtemplate
|
||||
(begin
|
||||
<define-fold-result>)))]))]
|
||||
|
||||
@chunk[<define-fold-prepare>
|
||||
(define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
|
||||
(define-temp-ids "_Aᵢ" (type-to-replaceᵢ …))
|
||||
(define-temp-ids "_Bᵢ" (type-to-replaceᵢ …))
|
||||
(define-temp-ids "predicateᵢ" (type-to-replaceᵢ …))
|
||||
(define-temp-ids "updateᵢ" (type-to-replaceᵢ …))
|
||||
|
||||
(define/with-syntax _args (template ({?@ predicateᵢ updateᵢ} …)))]
|
||||
@chunk[<define-fold-result>
|
||||
the-defs …
|
||||
|
||||
(define-type (_type-name _Tᵢ …) _the-type)
|
||||
|
||||
(: _function-name (∀ (_Aᵢ … _Bᵢ … Acc)
|
||||
(→ (?@ (→ Any Boolean : _Aᵢ)
|
||||
(→ _Aᵢ Acc (Values _Bᵢ Acc)))
|
||||
…
|
||||
(→ (_type-name _Aᵢ …)
|
||||
Acc
|
||||
(Values (_type-name _Bᵢ …)
|
||||
Acc)))))
|
||||
(define ((_function-name . _args) v acc)
|
||||
_the-code)]
|
||||
|
||||
@chunk[<define-fold-prepare>
|
||||
;(define-temp-ids "_Tᵢ" (type-to-replaceᵢ …))
|
||||
;(define-temp-ids "_Aᵢ" (type-to-replaceᵢ …))
|
||||
;(define-temp-ids "_Bᵢ" (type-to-replaceᵢ …))
|
||||
;(define-temp-ids "predicateᵢ" (type-to-replaceᵢ …))
|
||||
;(define-temp-ids "updateᵢ" (type-to-replaceᵢ …))
|
||||
|
||||
(define/with-syntax _args (subtemplate ({?@ predicateᵢ updateᵢ} …)))]
|
||||
|
||||
@chunk[<define-fold-prepare>
|
||||
(type-cases
|
||||
|
|
@ -302,7 +319,7 @@ where @racket[foldl-map] is defined as:
|
|||
#:using the-code
|
||||
#:with-defintitions the-defs (~literal …))
|
||||
#:literals (lit …)
|
||||
(Pat opts …
|
||||
(pat opts …
|
||||
#:to transform-type
|
||||
#:using transform-code
|
||||
(~optional (~seq #:with-defintitions transform-defs …)
|
||||
|
|
@ -311,38 +328,25 @@ where @racket[foldl-map] is defined as:
|
|||
#'(define/with-syntax (the-type the-code the-defs (… …))
|
||||
(syntax-parse #'whole-type
|
||||
#:literals (lit …)
|
||||
[Pat opts …
|
||||
(template
|
||||
[pat opts …
|
||||
(subtemplate
|
||||
(transform-type transform-code transform-defs …))]
|
||||
…))]))]
|
||||
|
||||
@chunk[<define-fold-result>
|
||||
the-defs …
|
||||
|
||||
(define-type (_type-name _Tᵢ …) _the-type)
|
||||
|
||||
(: _function-name (∀ (_Aᵢ … _Bᵢ … Acc)
|
||||
(→ (?@ (→ Any Boolean : _Aᵢ)
|
||||
(→ _Aᵢ Acc (Values _Bᵢ Acc)))
|
||||
…
|
||||
(→ (_type-name _Aᵢ …)
|
||||
Acc
|
||||
(Values (_type-name _Bᵢ …)
|
||||
Acc)))))
|
||||
(define ((_function-name . _args) v acc)
|
||||
_the-code)]
|
||||
|
||||
@section{Putting it all together}
|
||||
|
||||
@chunk[<*>
|
||||
(require phc-toolkit
|
||||
(require racket/require
|
||||
phc-toolkit
|
||||
type-expander
|
||||
phc-adt
|
||||
"dispatch-union.rkt"
|
||||
(for-syntax racket/base
|
||||
(for-syntax "subtemplate.rkt"
|
||||
(subtract-in racket/base "subtemplate.rkt")
|
||||
phc-toolkit/untyped
|
||||
racket/syntax
|
||||
syntax/parse
|
||||
(subtract-in syntax/parse "subtemplate.rkt")
|
||||
syntax/parse/experimental/template
|
||||
type-expander/expander
|
||||
"free-identifier-tree-equal.rkt")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user