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

Use emit-local-step with match expanders.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-10 18:57:51 -04:00
parent 490361c0fc
commit 4ac05ce5bd
1 changed files with 6 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/racket/match/parse-helper.rkt
View File

@ -4,6 +4,7 @@
syntax/boundmap syntax/boundmap
syntax/stx syntax/stx
scheme/struct-info scheme/struct-info
macro-debugger/emit
"patterns.rkt" "patterns.rkt"
"compiler.rkt") "compiler.rkt")
@ -135,18 +136,19 @@
;; produces a parsed pattern ;; produces a parsed pattern
(define (match-expander-transform parse/cert cert expander stx accessor (define (match-expander-transform parse/cert cert expander stx accessor
error-msg) error-msg)
(let* ([expander (syntax-local-value (cert expander))] (let* ([expander* (syntax-local-value (cert expander))]
[transformer (accessor expander)] [transformer (accessor expander*)]
[transformer (if (set!-transformer? transformer) [transformer (if (set!-transformer? transformer)
(set!-transformer-procedure transformer) (set!-transformer-procedure transformer)
transformer)]) transformer)])
(unless transformer (raise-syntax-error #f error-msg expander)) (unless transformer (raise-syntax-error #f error-msg expander*))
(let* ([introducer (make-syntax-introducer)] (let* ([introducer (make-syntax-introducer)]
[certifier (match-expander-certifier expander)] [certifier (match-expander-certifier expander*)]
[mstx (introducer (syntax-local-introduce stx))] [mstx (introducer (syntax-local-introduce stx))]
[mresult (transformer mstx)] [mresult (transformer mstx)]
[result (syntax-local-introduce (introducer mresult))] [result (syntax-local-introduce (introducer mresult))]
[cert* (lambda (id) (certifier (cert id) #f introducer))]) [cert* (lambda (id) (certifier (cert id) #f introducer))])
(emit-local-step stx result #:id expander)
(parse/cert result cert*)))) (parse/cert result cert*))))
;; raise an error, blaming stx ;; raise an error, blaming stx