suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Factor observe-step into separate file.

Browse Source 
Use observe step in match.ss match-expanders.
This commit is contained in:
Sam Tobin-Hochstadt 2006-09-11 15:43:50 -04:00
parent 7646ee635d
commit ee63e4e80d
3 changed files with 56 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/mzlib/private/match/convert-pat.ss
View File

@ -1,7 +1,8 @@
(module convert-pat mzscheme (module convert-pat mzscheme
(require "match-error.ss" (require "match-error.ss"
"match-helper.ss" "match-helper.ss"
"match-expander-struct.ss") "match-expander-struct.ss"
"observe-step.ss")
(require-for-template mzscheme (require-for-template mzscheme
"match-error.ss") "match-error.ss")
@ -84,13 +85,15 @@
[xformer (match-expander-match-xform expander)]) [xformer (match-expander-match-xform expander)])
(if (not xformer) (if (not xformer)
(match:syntax-err #'expander (match:syntax-err #'expander
"This expander only works with plt-match.") "This expander only works with plt-match.ss.")
(let ([introducer (make-syntax-introducer)] (let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)]) [certifier (match-expander-certifier expander)]
(convert-pat/cert [mstx (introducer stx)]
(introducer (xformer (introducer stx))) [mresult (xformer mstx)]
(lambda (id) [result (introducer mresult)]
(certifier (cert id) #f introducer))))))] [cert* (lambda (id) (certifier (cert id) #f introducer))])
(observe-step stx mstx mresult result)
(convert-pat/cert result cert*))))]
[p [p
(dot-dot-k? (syntax-object->datum #'p)) (dot-dot-k? (syntax-object->datum #'p))
stx] stx]

43
collects/mzlib/private/match/observe-step.ss Normal file
View File

@ -0,0 +1,43 @@
(module observe-step mzscheme
(provide observe-step)
(define current-expand-observe
(dynamic-require '#%expobs 'current-expand-observe))
(define (observe-step pre mpre mpost post)
(define (call-obs ev . args)
(let ([obs (current-expand-observe)])
(if obs
(let ([evn (case ev
[(visit) 0]
[(enter-prim) 6]
[(prim-stop) 100]
[(exit-prim) 7]
[(return) 2]
[(macro-enter) 8]
[(macro-exit) 9]
[(macro-pre) 21]
[(macro-post) 22]
[(local-enter) 130]
[(local-exit) 131]
[(local-pre) 132]
[(local-post) 133])])
(apply obs evn args)))))
(call-obs 'local-enter pre)
(call-obs 'local-pre pre)
(call-obs 'visit pre)
(call-obs 'macro-enter pre)
(call-obs 'macro-pre mpre)
(call-obs 'macro-post mpost)
(call-obs 'macro-exit post)
(call-obs 'visit post)
(call-obs 'enter-prim post)
(call-obs 'prim-stop #f)
(call-obs 'exit-prim post)
(call-obs 'return post)
(call-obs 'local-post post)
(call-obs 'local-exit post)
)
)

41
collects/mzlib/private/match/simplify-patterns.ss
View File

@ -11,7 +11,8 @@
"update-binding-counts.scm" "update-binding-counts.scm"
"reorder-tests.scm" "reorder-tests.scm"
"match-expander-struct.ss" "match-expander-struct.ss"
"render-helpers.ss") "render-helpers.ss"
"observe-step.ss")
(require "render-sigs.ss" (require "render-sigs.ss"
(lib "unitsig.ss")) (lib "unitsig.ss"))
@ -26,44 +27,6 @@
"match-helper.ss") "match-helper.ss")
(define current-expand-observe
(dynamic-require '#%expobs 'current-expand-observe))
(define (observe-step pre mpre mpost post)
(define (call-obs ev . args)
(let ([obs (current-expand-observe)])
(if obs
(let ([evn (case ev
[(visit) 0]
[(enter-prim) 6]
[(prim-stop) 100]
[(exit-prim) 7]
[(return) 2]
[(macro-enter) 8]
[(macro-exit) 9]
[(macro-pre) 21]
[(macro-post) 22]
[(local-enter) 130]
[(local-exit) 131]
[(local-pre) 132]
[(local-post) 133])])
(apply obs evn args)))))
(call-obs 'local-enter pre)
(call-obs 'local-pre pre)
(call-obs 'visit pre)
(call-obs 'macro-enter pre)
(call-obs 'macro-pre mpre)
(call-obs 'macro-post mpost)
(call-obs 'macro-exit post)
(call-obs 'visit post)
(call-obs 'enter-prim post)
(call-obs 'prim-stop #f)
(call-obs 'exit-prim post)
(call-obs 'return post)
(call-obs 'local-post post)
(call-obs 'local-exit post)
)
(provide simplify) (provide simplify)