90 lines
3.3 KiB
Scheme
90 lines
3.3 KiB
Scheme
|
|
(module synth-engine mzscheme
|
|
(require "deriv.ss"
|
|
"deriv-util.ss"
|
|
"stx-util.ss"
|
|
(lib "plt-match.ss"))
|
|
|
|
(provide recv
|
|
>>P
|
|
>>Pn
|
|
>>Prim
|
|
>>Seek
|
|
macro-policy
|
|
subterms-table
|
|
)
|
|
|
|
|
|
;; macro-policy : parameter of (identifier -> boolean)
|
|
(define macro-policy (make-parameter (lambda (id) #t)))
|
|
|
|
;; subterms-table : parameter of hashtable[syntax => (list-of Path)]
|
|
(define subterms-table (make-parameter #f))
|
|
|
|
;; Macros
|
|
|
|
(define-syntax recv
|
|
(syntax-rules ()
|
|
[(recv body)
|
|
body]
|
|
[(recv [(var ...) expr] . more)
|
|
(let-values ([(var ...) expr]) (recv . more))]))
|
|
|
|
(define-syntax (>>P stx)
|
|
(syntax-case stx ()
|
|
[(>>P pr (constructor var ...) pattern . clauses)
|
|
#'(>>Prim pr #t (constructor var ...) pattern pattern . clauses)]))
|
|
|
|
;; >>P with no restamping
|
|
(define-syntax (>>Pn stx)
|
|
(syntax-case stx ()
|
|
[(>>Pn pr (constructor var ...) pattern . clauses)
|
|
#'(>>Prim pr #f (constructor var ...) pattern pattern . clauses)]))
|
|
|
|
(define-syntax (>>Prim stx)
|
|
(syntax-case stx ()
|
|
[(>>Prim pr restamp? cons+vars inp outp clauses)
|
|
#'(>>Prim pr restamp? cons+vars inp outp clauses #:with values)]
|
|
[(>>Prim pr restamp? cons+vars inp outp clauses #:with transform)
|
|
#'(>>Prim pr restamp? cons+vars inp outp clauses
|
|
#:with2 (lambda (pr stx) (values pr (transform stx))))]
|
|
[(>>Prim pr restamp? (constructor var ...)
|
|
in-pattern
|
|
out-pattern
|
|
([recur hole fill/bind] ...)
|
|
#:with2 transform)
|
|
(let ([restamp? (syntax-e #'restamp?)])
|
|
(with-syntax ([(s-tmp ...) (generate-temporaries #'(fill/bind ...))])
|
|
#`(let ([prule-var pr])
|
|
(let-values ([(fill/bind s-tmp)
|
|
(let ([fbvar fill/bind])
|
|
(if fbvar (recur fbvar) (values fbvar #f)))] ...)
|
|
(let ([new-e2 (if (or (interrupted-wrap? prule-var) (error-wrap? prule-var))
|
|
#f
|
|
(with-syntax ([in-pattern (deriv-e1 prule-var)])
|
|
(with-syntax ([hole s-tmp] ...)
|
|
#,(if restamp?
|
|
#'(syntax/restamp out-pattern #'out-pattern
|
|
(deriv-e2 prule-var))
|
|
#'#'out-pattern))))])
|
|
(let ([new-pr
|
|
(match prule-var
|
|
[($$ prule (e1 _ rs) _exni)
|
|
(constructor e1 new-e2 rs var ...)])])
|
|
(let-values ([(new-pr new-e2) (transform new-pr new-e2)])
|
|
(values (rewrap prule-var new-pr)
|
|
new-e2))))))))]))
|
|
|
|
(define-syntax >>Seek
|
|
(syntax-rules (!)
|
|
[(>>Seek) null]
|
|
[(>>Seek [! tag exni] . more)
|
|
(if (and (pair? exni) (eq? tag (car exni)))
|
|
null
|
|
(>>Seek . more))]
|
|
[(>>Seek [#:table t] . more)
|
|
(parameterize ((subterms-table t)) (>>Seek . more))]
|
|
[(>>Seek expr . more)
|
|
(append expr (>>Seek . more))]))
|
|
|
|
) |