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

Use an extra let binding to make Typed Scheme happy.

Browse Source 
svn: r8366
This commit is contained in:
Sam Tobin-Hochstadt 2008-01-18 22:44:54 +00:00
parent cd239fc23c
commit 3f93fd0f25
3 changed files with 58 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,7 +8,8 @@
"render-helpers.ss"
"render-sigs.ss"
(lib "stx.ss" "syntax")
(lib "unit.ss"))
(lib "unit.ss")
(lib "trace.ss"))
(require-for-template mzscheme
"test-no-order.ss")
@ -90,28 +91,32 @@
(lambda (x) #`(reverse #,x))
binding-list-names))
bv))
#,(next-outer #'the-pat
#`(car #,exp-name)
sf
bv ;; we always start
;; over with the old
;; 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)))
cert))))]))))
#,(let ([new-var (gensym 'exp)])
#`(let ([#,new-var (car #,exp-name)])
#,(next-outer #'the-pat
#`#,new-var
sf
;(append (map cons bound new-vars) bv)
bv
;; we always start
;; over with the old
;; 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)))
cert))))))]))))
(define (new-emit f) (emit f ae let-bound sf bv kf ksucc))
(case k
((0) (ksucc sf bv))

24
collects/mzlib/private/match/render-helpers.ss
View File

@ -8,7 +8,8 @@
"getter-setter.scm"
"parse-quasi.scm"
"test-structure.scm"
(lib "etc.ss"))
(lib "etc.ss")
(lib "trace.ss"))
(require-for-template mzscheme
(lib "list.ss")
@ -32,18 +33,15 @@
[p #'p]))
(define (get-bind-val b-var bv-list)
(let ((res (assq
b-var
bv-list)))
(if res (cdr res)
(let ((res
(assq
(syntax-object->datum b-var)
(map (lambda (x)
(cons
(syntax-object->datum (car x)) (cdr x)))
bv-list))))
(if res (cdr res) (error 'var-not-found))))))
(cond [(assq b-var bv-list) => cdr]
[(assq
(syntax-object->datum b-var)
(map (lambda (x)
(cons
(syntax-object->datum (car x)) (cdr x)))
bv-list))
=> cdr]
[else (error 'var-not-found)]))
;;!(function proper-hash-table-pattern?

37
collects/mzlib/private/match/render-test-list-impl.ss
View File

@ -419,27 +419,28 @@
'(unquote unquote-splicing ... ___))
(stx-dot-dot-k? (syntax pat))))
(stx-dot-dot-k? (syntax dot-dot-k)))
(list
(shape-test
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(if (stx-null? (syntax (pat-rest ...)))
(handle-end-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
let-bound
cert)
(handle-inner-ddk-list ae kf ks
(begin
(list
(shape-test
`(list? ,ae-datum)
ae (lambda (exp) #`(list? #,exp)))
(make-act
'list-ddk-pat
ae
(lambda (ks kf let-bound)
(if (stx-null? (syntax (pat-rest ...)))
(handle-end-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
(append-if-necc 'list
(syntax (pat-rest ...)))
let-bound
cert))))))
cert)
(handle-inner-ddk-list ae kf ks
(syntax pat)
(syntax dot-dot-k)
(append-if-necc 'list
(syntax (pat-rest ...)))
let-bound
cert)))))))
;; list-rest pattern with a ooo or ook pattern
((list-rest pat dot-dot-k pat-rest ...)