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

render-test-list:

Browse Source 
- cleanups and removal of quasisyntax/loc

svn: r1281
This commit is contained in:
Sam Tobin-Hochstadt 2005-11-11 18:35:08 +00:00
parent 3478a782b7
commit bb69014fc7
1 changed files with 21 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/mzlib/private/render-test-list.scm
View File

@ -177,24 +177,7 @@
(lambda (sf bv) #'(dummy-symbol)) (lambda (sf bv) #'(dummy-symbol))
(lambda (sf bv) (out (map car bv)))))) (lambda (sf bv) (out (map car bv))))))
;; END SPECIAL-GENERATORS.SCM
;; BEGIN DDK
;; END DDK
;; BEGIN DDK-HANDLERS.SCM
;;!(function handle-end-ddk-list ;;!(function handle-end-ddk-list
;; (form (handle-end-ddk-list ae kf ks pat ;; (form (handle-end-ddk-list ae kf ks pat
;; dot-dot-k ;; dot-dot-k
@ -360,12 +343,12 @@
(with-syntax ((exp-sym (syntax exp-sym))) (with-syntax ((exp-sym (syntax exp-sym)))
(let* ((ptst (next-outer (let* ((ptst (next-outer
pat pat
(syntax exp-sym) #'exp-sym
sf sf
bv bv
let-bound let-bound
(lambda (sf bv) (syntax #f)) (lambda (sf bv) #'#f)
(lambda (sf bv) (syntax #t)))) (lambda (sf bv) #'#t)))
(tst (syntax-case ptst () (tst (syntax-case ptst ()
((pred eta) ((pred eta)
(and (identifier? (and (identifier?
@ -380,9 +363,7 @@
(loop-name (gensym 'ddnnl)) (loop-name (gensym 'ddnnl))
(exp-name (gensym 'exp)) (exp-name (gensym 'exp))
(count-name (gensym 'count))) (count-name (gensym 'count)))
(quasisyntax/loc #`(let #,loop-name ((#,exp-name
(syntax the-pat)
(let #,loop-name ((#,exp-name
#,(subst-bindings ae let-bound)) #,(subst-bindings ae let-bound))
(#,count-name 0)) (#,count-name 0))
(if (and (not (null? #,exp-name)) (if (and (not (null? #,exp-name))
@ -395,8 +376,7 @@
;; if the count is zero ;; if the count is zero
#,(let ((succ (next-outer #,(let ((succ (next-outer
pat-rest pat-rest
(quasisyntax/loc #`#,exp-name
(syntax the-pat) #,exp-name)
sf sf
bv bv
let-bound let-bound
@ -404,11 +384,9 @@
ks))) ks)))
(if (zero? k) (if (zero? k)
succ succ
(quasisyntax/loc #`(if (>= #,count-name #,k)
(syntax the-pat)
(if (>= #,count-name #,k)
#,succ #,succ
#,(kf sf bv))))))))))) #,(kf sf bv)))))))))
(the-pat (the-pat
(let* ((binding-list-names (let* ((binding-list-names
(map (lambda (x) (map (lambda (x)
@ -418,41 +396,27 @@
(gensym (syntax-object->datum x)) (gensym (syntax-object->datum x))
'-bindings))) '-bindings)))
bound)) bound))
(loop-name (quasisyntax/loc (loop-name #`#,(gensym 'loop))
(syntax the-pat) (exp-name #`#,(gensym 'exp))
#,(gensym 'loop))) (fail-name #`#,(gensym 'fail))
(exp-name (quasisyntax/loc (count-name #`#,(gensym 'count))
(syntax the-pat)
#,(gensym 'exp)))
(fail-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'fail)))
(count-name (quasisyntax/loc
(syntax the-pat)
#,(gensym 'count)))
(new-bv (append (new-bv (append
(map cons (map cons
bound bound
(map (map
(lambda (x) #`(reverse #,x)) (lambda (x) #`(reverse #,x))
binding-list-names)) bv))) binding-list-names)) bv)))
(quasisyntax/loc #`(let #,loop-name
(syntax the-pat)
(let #,loop-name
((#,exp-name #,(subst-bindings ae let-bound)) ((#,exp-name #,(subst-bindings ae let-bound))
(#,count-name 0) (#,count-name 0)
#,@(map #,@(map
(lambda (x) (quasisyntax/loc (lambda (x) #`(#,x '()))
(syntax the-pat)
(#,x '())))
binding-list-names)) binding-list-names))
(let ((#,fail-name (let ((#,fail-name
(lambda () (lambda ()
#,(let ((succ (next-outer #,(let ((succ (next-outer
pat-rest pat-rest
(quasisyntax/loc #`#,exp-name
(syntax the-pat)
#,exp-name)
sf sf
new-bv new-bv
let-bound let-bound
@ -460,27 +424,21 @@
ks))) ks)))
(if (zero? k) (if (zero? k)
succ succ
(quasisyntax/loc #`(if (>= #,count-name #,k)
(syntax the-pat)
(if (>= #,count-name #,k)
#,succ #,succ
#,(kf sf new-bv)))))))) #,(kf sf new-bv)))))))
(if (or (null? #,exp-name) (if (or (null? #,exp-name)
(not (pair? #,exp-name))) (not (pair? #,exp-name)))
(#,fail-name) (#,fail-name)
#,(next-outer (syntax the-pat) #,(next-outer #'the-pat
(quasisyntax/loc #`(car #,exp-name)
(syntax the-pat)
(car #,exp-name))
sf sf
bv ;; we always start bv ;; we always start
;; over with the old ;; over with the old
;; bindings ;; bindings
let-bound let-bound
(lambda (sf bv) (lambda (sf bv)
(quasisyntax/loc #`(#,fail-name))
(syntax the-pat)
(#,fail-name)))
(lambda (sf bv) (lambda (sf bv)
#`(#,loop-name #`(#,loop-name
(cdr #,exp-name) (cdr #,exp-name)
@ -495,7 +453,7 @@
bv) bv)
#,bindings-var)) #,bindings-var))
bound bound
binding-list-names))))))))))))))) binding-list-names))))))))))))))
;;!(function handle-ddk-vector ;;!(function handle-ddk-vector
;; (form (handle-ddk-vector ae kf ks let-bound) ;; (form (handle-ddk-vector ae kf ks let-bound)
;; -> ;; ->
@ -763,8 +721,6 @@
sf sf
bv))))))))) bv)))))))))
;; END DDK-HANDLERS.SCM
;; some convenient syntax for make-reg-test and make-shape-test ;; some convenient syntax for make-reg-test and make-shape-test
(define make-test-gen (define make-test-gen
(case-lambda (case-lambda
@ -795,7 +751,7 @@
(with-syntax ([sym (syntax-case #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])]) (with-syntax ([sym (syntax-case #'set!/get! (set! get!) ['set! #''set!-pat] ['get! #''get!-pat])])
#`(syntax-case arg () #`(syntax-case arg ()
[(ident) [(ident)
(identifier? (syntax ident)) (identifier? #'ident)
(list (make-act (list (make-act
sym sym
ae ae