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

Use let-bound identifiers properly for handle-end-ddk-list.

Browse Source 
svn: r8372
This commit is contained in:
Sam Tobin-Hochstadt 2008-01-20 14:36:32 +00:00
parent f2c9c59b06
commit f951cac011
3 changed files with 35 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/mzlib/private/match/ddk-handlers.ss
View File

@ -93,7 +93,7 @@
bv))
#,(let ([new-var (gensym 'exp)])
#`(let ([#,new-var (car #,exp-name)])
#,(next-outer #'the-pat
#,(next-outer* #'the-pat
#`#,new-var
sf
;(append (map cons bound new-vars) bv)
@ -103,19 +103,26 @@
;; bindings
let-bound
kf
(lambda (sf bv)
#`(#,loop-name
(cdr #,exp-name)
#,@(map
(lambda
(b-var
bindings-var)
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var))
bound binding-list-names)))
(lambda (let-bound)
(lambda (sf bv)
;(printf "let-bound is: ~a~n" let-bound)
;(printf "bv is: ~a ~a~n"
; (map syntax-e (map car bv))
; (map syntax-object->datum (map cdr bv)))
#`(#,loop-name
(cdr #,exp-name)
#,@(map
(lambda
(b-var
bindings-var)
(subst-bindings
#`(cons
#,(get-bind-val
b-var
bv)
#,bindings-var)
let-bound))
bound binding-list-names))))
cert))))))]))))
(define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
(case k

13
collects/mzlib/private/match/getbindings.ss
View File

@ -41,6 +41,19 @@
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) ks) cert stx))
(define/opt (next-outer*
p
ae ;; this is the actual expression
sf
bv
let-bound
kf
ks
cert
[stx (syntax '())])
(next-outer-helper p ae sf bv let-bound
(lambda (x) kf) (lambda (a b) (ks b)) cert stx))
;;!(function next-outer-helper
;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool)
;; ->

2
collects/mzlib/private/match/render-sigs.ss
View File

@ -7,6 +7,6 @@
(define-signature ddk-handlers^ (handle-end-ddk-list handle-inner-ddk-list handle-ddk-vector handle-ddk-vector-inner))
(define-signature getbindings^ (getbindings create-test-func next-outer))
(define-signature getbindings^ (getbindings create-test-func next-outer next-outer*))
)