You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2311 lines
69 KiB
Scheme
2311 lines
69 KiB
Scheme
;;; 3.ms
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
(define-syntax matrest
|
|
(lambda (x)
|
|
(define matrest-argerr-test
|
|
(lambda (ls)
|
|
(if (null? ls)
|
|
'()
|
|
(cons (with-syntax (((n ...) (make-list (length (cdr ls)) 1)))
|
|
(syntax (error? (matrestf n ...))))
|
|
(matrest-argerr-test (cdr ls))))))
|
|
(define iota
|
|
(lambda (i n)
|
|
(if (= i n)
|
|
'()
|
|
(cons i (iota (+ i 1) n)))))
|
|
(define matrest-test
|
|
(lambda (n ls)
|
|
(let* ((m (length ls)) (n (+ n m)))
|
|
(let f ((n n))
|
|
(if (< n m)
|
|
'()
|
|
(cons (with-syntax (((x ...) (iota 0 m))
|
|
((y ...) (iota m n)))
|
|
(syntax (equal? (matrestf x ... y ...)
|
|
'(y ...))))
|
|
(f (- n 1))))))))
|
|
(syntax-case x ()
|
|
((k n)
|
|
(let ((n (datum n)))
|
|
(with-syntax (((g ...) (generate-temporaries (make-list n)))
|
|
(name (datum->syntax (syntax k)
|
|
(string->symbol (format "matrest~s" n)))))
|
|
(with-syntax (((at ...) (matrest-argerr-test (syntax (g ...))))
|
|
((t ...) (matrest-test 10 (syntax (g ...)))))
|
|
(syntax
|
|
(mat name
|
|
(begin (define (matrestf g ... . r) r) #t)
|
|
at ...
|
|
t ...
|
|
)))))))))
|
|
|
|
(matrest 0)
|
|
(matrest 1)
|
|
(matrest 2)
|
|
(matrest 3)
|
|
(matrest 4)
|
|
(matrest 5)
|
|
(matrest 6)
|
|
(matrest 7)
|
|
(matrest 8)
|
|
(matrest 9)
|
|
(matrest 10)
|
|
|
|
(mat application
|
|
(error? ((list '(a b c))))
|
|
)
|
|
|
|
(mat lambda
|
|
(let ((f (lambda () 'a))) (eq? (f) 'a))
|
|
(let ((f (lambda (x) x))) (eq? (f 'a) 'a))
|
|
(let ((f (lambda x x)))
|
|
(and (equal? (f) '())
|
|
(equal? (f 1) '(1))
|
|
(equal? (f 1 2) '(1 2))
|
|
(equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
|
|
(let ((f (lambda (x y) (cons x y)))) (equal? (f 1 2) '(1 . 2)))
|
|
(let ((f (lambda (x . y) (cons x y))))
|
|
(and (equal? (f 1) '(1))
|
|
(equal? (f 1 2) '(1 2))
|
|
(equal? (f 1 2 3) '(1 2 3))
|
|
(equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
|
|
(let ((f (lambda (x y z) (list x y z)))) (equal? (f 1 2 3) '(1 2 3)))
|
|
(let ((f (lambda (x y . z) (cons x (cons y z)))))
|
|
(and (equal? (f 1 2) '(1 2))
|
|
(equal? (f 1 2 3) '(1 2 3))
|
|
(equal? (f 1 2 3 4) '(1 2 3 4))
|
|
(equal? (f 1 2 3 4 5 6 7) '(1 2 3 4 5 6 7))))
|
|
(let ((f (lambda (x y) (set! x 3) (cons x y))))
|
|
;see if there is an implicit "begin"
|
|
(equal? (f 1 2) '(3 . 2)))
|
|
(eqv?
|
|
(let ((f (case-lambda
|
|
((x) (+ x 1))
|
|
((x . xs) (cons (+ x 2) xs))
|
|
(xs 0))))
|
|
(f))
|
|
0)
|
|
)
|
|
|
|
(mat case-lambda
|
|
(procedure? (case-lambda))
|
|
(error? ((case-lambda)))
|
|
(error? (let ((f (case-lambda))) (f 3 4 5)))
|
|
(begin
|
|
(define foo (case-lambda [() 0] [(a b c) 3]))
|
|
(eq? (foo 1 2 3) 3))
|
|
(eq? (foo) 0)
|
|
(error? (foo 1))
|
|
(error? (foo 1 2))
|
|
(error? (foo 1 2 3 4))
|
|
(begin
|
|
(define foo (case-lambda [(a b c) 3] [() 0]))
|
|
(eq? (foo 1 2 3) 3))
|
|
(eq? (foo) 0)
|
|
(error? (foo 1))
|
|
(error? (foo 1 2))
|
|
(error? (foo 1 2 3 4))
|
|
(begin
|
|
(define foo (case-lambda [() 0] [(a) 1] [args 2]))
|
|
(eq? (foo 1 2 3) 2))
|
|
(eq? (foo) 0)
|
|
(eq? (foo 1) 1)
|
|
(begin
|
|
(define foo (case-lambda [() 0] [(a) 1] [(a b c . args) 3]))
|
|
(eq? (foo 1 2 3) 3))
|
|
(eq? (foo) 0)
|
|
(eq? (foo 1) 1)
|
|
(error? (foo 1 2))
|
|
(begin
|
|
(define foo (case-lambda [() 0] [args 1] [(a b c . args) 3]))
|
|
(and (eq? (foo 1 2 3) 1)
|
|
(eq? (foo 1 2) 1)
|
|
(eq? (foo 1) 1)
|
|
(eq? (foo) 0)))
|
|
)
|
|
|
|
(mat let
|
|
(let ((x 'a)) (eq? x 'a))
|
|
(let ((x 'a)) (let ((x 'b)) (eq? x 'b)))
|
|
(let ((x 'a) (y 'b)) (equal? (cons x y) '(a . b)))
|
|
(let ((x 'a))
|
|
;test for implicit "begin"
|
|
(let ((y 'b)) #f (set! x y))
|
|
(eq? x 'b))
|
|
((lambda (x) (eq? x 'a)) 'a)
|
|
((lambda (x . r) (eq? x 'a)) 'a)
|
|
((lambda r (eq? (car r) 'a)) 'a)
|
|
(error? ((lambda (x . r) (eq? x 'a))))
|
|
)
|
|
|
|
(mat let*
|
|
(let* ((x 'a)) (eq? x 'a))
|
|
(let* ((x (cons 1 2)) (y x)) (eq? x y))
|
|
(let ((x 1) (y 2)) (let* ((x 10) (y 12)) (equal? (cons x y) '(10 . 12))))
|
|
(let* ((x 'a))
|
|
;test for implicit "begin"
|
|
(let* ((y 'b)) #f (set! x y))
|
|
(eq? x 'b))
|
|
)
|
|
|
|
(mat letrec
|
|
(letrec ((f (lambda () x)) (x (cons 1 2))) (eq? (f) x))
|
|
(letrec ((f (lambda () g)) (g (lambda () f)))
|
|
(and (eq? (f) g) (eq? (g) f)))
|
|
(letrec ((f (lambda (x) (if (zero? x) 'odd (g (1- x)))))
|
|
(g (lambda (x) (if (zero? x) 'even (f (1- x))))))
|
|
(and
|
|
(eq? (g 10) 'even)
|
|
(eq? (g 13) 'odd)
|
|
(eq? (f 13) 'even)))
|
|
(letrec ((x 'a))
|
|
;test for implicit "begin"
|
|
(letrec ((y 'b)) #f (set! x y))
|
|
(eq? x 'b))
|
|
#;(eqv? (letrec ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
|
|
; david carlton's bug
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
1)
|
|
#;(eqv? (letrec ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
|
|
; david carlton's bug
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
1)
|
|
#;(eqv? (letrec* ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
|
|
; variation on david carlton's "bug"
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
2)
|
|
#;(eqv? (letrec* ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
|
|
; another variation on david carlton's "bug"
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
1)
|
|
; testing for named-let equivalents
|
|
(eqv? (letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (1- x))))))) (f 5))
|
|
120)
|
|
(letrec ((f (lambda (x) (if (zero? x) #t (f (1- x)))))) (f 10000))
|
|
(letrec ((f (lambda (x y) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))))
|
|
(f 10 0))
|
|
(eqv? (letrec ((f (lambda (x) (if (= x 0) 1 (+ (f (- x 1)) 1))))) (f 10)) 11)
|
|
(eqv? (let ([base 20])
|
|
(letrec ((f (lambda (x)
|
|
(if (= x 0) base
|
|
(+ (f (- x 1)) 1)))))
|
|
(f 10)))
|
|
30)
|
|
(error? (letrec ((x (lambda (x) x))) (f 3 4)))
|
|
(eq? (letrec ((f (lambda (x) (if x (list (f x)) 0)))) (f #f)) 0)
|
|
(equal? (letrec ((f (lambda (x) (if x (list (f (not x))) 0)))) (f #t)) '(0))
|
|
(equal? (letrec ((f (lambda (x) (if x (list (g x)) 0)))
|
|
(g (lambda (x) (f #f))))
|
|
(f #t))
|
|
'(0))
|
|
(equal? (letrec ((f (lambda (x) (if x (list (g (not x))) 0)))
|
|
(g (lambda (x) (f x))))
|
|
(g #t))
|
|
'(0))
|
|
(error? (letrec ([a 3] [b a]) (+ a b)))
|
|
; shouldn't get warnings for these if valid-check algorithm is working
|
|
; properly
|
|
(procedure? (letrec ([bar (letrec ([f (lambda (x) f)]) f)]) bar))
|
|
(eqv?
|
|
(letrec ([fllog 3] [flacosh (or values (lambda (x) fllog))]) (flacosh 4))
|
|
4)
|
|
(eqv?
|
|
(let ()
|
|
(define $b #t)
|
|
(letrec ([fllog 3] [flacosh (if $b (lambda (x) fllog) values)])
|
|
(flacosh 4)))
|
|
3)
|
|
(equal?
|
|
(letrec ([a 3] [b (#2%cons (lambda () a) (lambda (x) (set! a x)))])
|
|
((cdr b) 17)
|
|
(list a ((car b))))
|
|
'(17 17))
|
|
#;(pair?
|
|
(member
|
|
(letrec ([k (call/cc (lambda (k) k))] ; invalid in r6rs
|
|
[f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))])
|
|
(f (void))
|
|
(let ([m (k f)])
|
|
(list (eq? k f) m (f (void)))))
|
|
'((#f 2 2) (#t 3 4))))
|
|
(error? (letrec ([a (set! b 0)] [b 3]) 17))
|
|
; test strongly connected components algorithm used by cpletrec
|
|
(equal?
|
|
(letrec ([f0 (lambda (x) (f4 (cons 0 x)))]
|
|
[f1 (lambda (x)
|
|
(if (fx> (length x) 10)
|
|
x
|
|
(f3 (f4 (cons 1 x)))))]
|
|
[f2 (lambda (x) (f3 (cons 2 x)))]
|
|
[f3 (lambda (x) (f1 (cons 3 x)))]
|
|
[f4 (lambda (x) (f1 (f2 (cons 4 x))))])
|
|
(apply
|
|
(lambda (t0 t1 t2 t3 t4)
|
|
(set! f0 (values t0))
|
|
(set! f1 (values t1))
|
|
(set! f2 (values t2))
|
|
(set! f3 (values t3))
|
|
(set! f4 (values t4)))
|
|
(list f0 f1 f2 f3 f4))
|
|
(f0 '()))
|
|
'(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
|
|
(equal?
|
|
(letrec ([f0 (list (lambda (x) ((car f4) (cons 0 x))))]
|
|
[f1 (list (lambda (x)
|
|
(if (fx> (length x) 10)
|
|
x
|
|
((car f3) ((car f4) (cons 1 x))))))]
|
|
[f2 (list (lambda (x) ((car f3) (cons 2 x))))]
|
|
[f3 (list (lambda (x) ((car f1) (cons 3 x))))]
|
|
[f4 (list (lambda (x) ((car f1) ((car f2) (cons 4 x)))))])
|
|
((car f0) '()))
|
|
'(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
|
|
)
|
|
|
|
(mat letrec*
|
|
(letrec* ((f (lambda () x)) (x (cons 1 2))) (eq? (f) x))
|
|
(letrec* ((f (lambda () g)) (g (lambda () f)))
|
|
(and (eq? (f) g) (eq? (g) f)))
|
|
(letrec* ((f (lambda (x) (if (zero? x) 'odd (g (1- x)))))
|
|
(g (lambda (x) (if (zero? x) 'even (f (1- x))))))
|
|
(and
|
|
(eq? (g 10) 'even)
|
|
(eq? (g 13) 'odd)
|
|
(eq? (f 13) 'even)))
|
|
(letrec* ((x 'a))
|
|
;test for implicit "begin"
|
|
(letrec ((y 'b)) #f (set! x y))
|
|
(eq? x 'b))
|
|
#;(eqv? (letrec* ((v 0) (k (call/cc (lambda (x) x)))) ; invalid in r6rs
|
|
; variation on david carlton's "bug"
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
2)
|
|
#;(eqv? (letrec* ((k (call/cc (lambda (x) x))) (v 0)) ; invalid in r6rs
|
|
; another variation on david carlton's "bug"
|
|
(set! v (+ v 1))
|
|
(k (lambda (x) v)))
|
|
1)
|
|
; testing for named-let equivalents
|
|
(eqv? (letrec* ((f (lambda (x) (if (zero? x) 1 (* x (f (1- x))))))) (f 5))
|
|
120)
|
|
(letrec* ((f (lambda (x) (if (zero? x) #t (f (1- x)))))) (f 10000))
|
|
(letrec* ((f (lambda (x y) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))))
|
|
(f 10 0))
|
|
(eqv? (letrec* ((f (lambda (x) (if (= x 0) 1 (+ (f (- x 1)) 1))))) (f 10)) 11)
|
|
(eqv? (let ([base 20])
|
|
(letrec* ((f (lambda (x)
|
|
(if (= x 0) base
|
|
(+ (f (- x 1)) 1)))))
|
|
(f 10)))
|
|
30)
|
|
(error? (letrec* ((x (lambda (x) x))) (f 3 4)))
|
|
(eq? (letrec* ((f (lambda (x) (if x (list (f x)) 0)))) (f #f)) 0)
|
|
(equal? (letrec* ((f (lambda (x) (if x (list (f (not x))) 0)))) (f #t)) '(0))
|
|
(equal? (letrec* ((f (lambda (x) (if x (list (g x)) 0)))
|
|
(g (lambda (x) (f #f))))
|
|
(f #t))
|
|
'(0))
|
|
(equal? (letrec* ((f (lambda (x) (if x (list (g (not x))) 0)))
|
|
(g (lambda (x) (f x))))
|
|
(g #t))
|
|
'(0))
|
|
(equal? (letrec* ((x 3) (y x)) (+ x y)) 6)
|
|
(equal?
|
|
(parameterize ([internal-defines-as-letrec* #t])
|
|
(eval '(let ()
|
|
(define x 3)
|
|
(define y x)
|
|
(+ x y))))
|
|
6)
|
|
(error? (letrec* ((y x) (x 3)) (+ x y)))
|
|
(error? (letrec* ((x x)) x))
|
|
; shouldn't get warnings for these if valid-check algorithm is working
|
|
; properly
|
|
(procedure? (letrec* ([bar (letrec* ([f (lambda (x) f)]) f)]) bar))
|
|
(eqv?
|
|
(letrec* ([fllog 3] [flacosh (or values (lambda (x) fllog))]) (flacosh 4))
|
|
4)
|
|
(eqv?
|
|
(let ()
|
|
(define $b #t)
|
|
(letrec* ([fllog 3] [flacosh (if $b (lambda (x) fllog) values)])
|
|
(flacosh 4)))
|
|
3)
|
|
(equal?
|
|
(letrec* ([a 3] [b (#2%cons (lambda () a) (lambda (x) (set! a x)))])
|
|
((cdr b) 17)
|
|
(list a ((car b))))
|
|
'(17 17))
|
|
(equal?
|
|
(letrec* ([f (let ([n 0]) (lambda () (set! n (+ n 1)) n))])
|
|
(letrec* ([x (f)] [y (f)])
|
|
(list x y)))
|
|
'(1 2))
|
|
(error? (letrec* ([a (set! b 0)] [b 3]) 17))
|
|
(eqv? (letrec* ([b 3] [a (set! b 0)]) 17) 17)
|
|
#;(equal?
|
|
(letrec* ([k (call/cc (lambda (k) k))] ; invalid in r6rs
|
|
[f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))])
|
|
(f (void))
|
|
(let ([m (k f)])
|
|
(list (eq? k f) m (f (void)))))
|
|
'(#f 2 2))
|
|
#;(equal?
|
|
(letrec* ([f (let ([n 0]) (lambda (a) (set! n (+ n 1)) n))]
|
|
[k (call/cc (lambda (k) k))]) ; invalid in r6rs
|
|
(f (void))
|
|
(let ([m (k f)])
|
|
(list (eq? k f) m (f (void)))))
|
|
'(#t 3 4))
|
|
|
|
; make sure letrec* doesn't treat global or local assignable
|
|
; variables simple
|
|
(begin
|
|
(define $frodo)
|
|
(letrec* ([merry 'merry]
|
|
[ignore (set! $frodo (lambda () pippin))]
|
|
[pippin (#3%cons $frodo $frodo)])
|
|
(void))
|
|
(eq? (car ($frodo)) $frodo))
|
|
(begin
|
|
(define $frodo)
|
|
(letrec* ([merry 'merry]
|
|
[ignore (set! $frodo (lambda () pippin))]
|
|
[pippin $frodo])
|
|
(void))
|
|
(eq? ($frodo) $frodo))
|
|
(let ([$frodo #f])
|
|
(letrec* ([merry 'merry]
|
|
[ignore (set! $frodo (lambda () pippin))]
|
|
[pippin $frodo])
|
|
(void))
|
|
(eq? ($frodo) $frodo))
|
|
|
|
; similarly, make sure letrec* doesn't reorder primitives that can
|
|
; observe effects of other expressions
|
|
(equal?
|
|
(letrec* ([t (cons 'a 'b)]
|
|
[f (lambda () y)]
|
|
[x (begin (set-car! t 'c) (car t))]
|
|
[p (car t)]
|
|
[g (lambda () x)]
|
|
[y (begin (set-car! t 'd) (car t))]
|
|
[q (car t)])
|
|
(list t p q x y (f) (g)))
|
|
`((d . b) c d c d d c))
|
|
|
|
(equal?
|
|
(letrec* ([t (gensym)]
|
|
[f (lambda () y)]
|
|
[x (list (putprop t 'ham f))]
|
|
[p (property-list t)]
|
|
[g (lambda () x)]
|
|
[y (list (putprop t 'spam g))]
|
|
[q (property-list t)])
|
|
(list
|
|
(equal? p (list 'ham f))
|
|
(or (equal? q (list 'ham f 'spam g))
|
|
(equal? q (list 'spam g 'ham f)))
|
|
(procedure? f)
|
|
(procedure? g)
|
|
x
|
|
y))
|
|
`(#t #t #t #t (,(void)) (,(void))))
|
|
; test strongly connected components algorithm used by cpletrec
|
|
(equal?
|
|
(letrec* ([f0 (lambda (x) (f4 (cons 0 x)))]
|
|
[f1 (lambda (x)
|
|
(if (fx> (length x) 10)
|
|
x
|
|
(f3 (f4 (cons 1 x)))))]
|
|
[f2 (lambda (x) (f3 (cons 2 x)))]
|
|
[f3 (lambda (x) (f1 (cons 3 x)))]
|
|
[f4 (lambda (x) (f1 (f2 (cons 4 x))))])
|
|
(apply
|
|
(lambda (t0 t1 t2 t3 t4)
|
|
(set! f0 (values t0))
|
|
(set! f1 (values t1))
|
|
(set! f2 (values t2))
|
|
(set! f3 (values t3))
|
|
(set! f4 (values t4)))
|
|
(list f0 f1 f2 f3 f4))
|
|
(f0 '()))
|
|
'(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
|
|
(equal?
|
|
(letrec* ([f0 (list (lambda (x) ((car f4) (cons 0 x))))]
|
|
[f1 (list (lambda (x)
|
|
(if (fx> (length x) 10)
|
|
x
|
|
((car f3) ((car f4) (cons 1 x))))))]
|
|
[f2 (list (lambda (x) ((car f3) (cons 2 x))))]
|
|
[f3 (list (lambda (x) ((car f1) (cons 3 x))))]
|
|
[f4 (list (lambda (x) ((car f1) ((car f2) (cons 4 x)))))])
|
|
((car f0) '()))
|
|
'(3 3 3 2 4 1 3 2 4 1 3 2 4 0))
|
|
)
|
|
|
|
(mat dipa-letrec ; from Dipa Sarkar
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)] [b (a)] [c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)]
|
|
[b (let ([d a]) (d))]
|
|
[c (cons 1 2)])
|
|
b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (let ([d (lambda () c)]) (d))]
|
|
[b a]
|
|
[c (cons 1 2)])
|
|
b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a
|
|
(letrec* ([b (lambda () c)] [d (b)] [c (cons 1 2)]) d)])
|
|
a))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)]
|
|
[b (lambda (f) (f))]
|
|
[d (b a)]
|
|
[c (cons 1 2)])
|
|
d))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)]
|
|
[b (lambda () a)]
|
|
[d ((b))]
|
|
[c (cons 1 2)])
|
|
d))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () (set! c d))]
|
|
[b (a)]
|
|
[c (cons 1 2)])
|
|
b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () (set! d c))]
|
|
[b (a)]
|
|
[c (cons 1 2)])
|
|
d))
|
|
|
|
(equal?
|
|
(letrec* ([a (lambda () c)]
|
|
[b (if #t a (a))]
|
|
[c (cons 1 2)])
|
|
(b))
|
|
'(1 . 2))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)]
|
|
[b (if #t (a) a)]
|
|
[c (cons 1 2)])
|
|
b))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (letrec* ([b (lambda () a)]) (b))]
|
|
[c (cons 1 2)])
|
|
(cons a c)))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (lambda () c)]
|
|
[b (lambda () a)]
|
|
[c ((b))]
|
|
[d (cons 1 2)])
|
|
d))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (lambda () b)][b (lambda () c)][c (a)]) c))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a
|
|
(letrec* ([b (lambda () c)] [c (cons 1 2)]) (b))]
|
|
[d a])
|
|
d))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (let ([x 0])(lambda () x))][b (let ([y 2]) (* y (a)))]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec ([a (letrec* ([b (lambda () c)] [d c]) (b))]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec ([a (letrec* ([b (lambda () c)] [d c]) b)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
|
|
|
|
(equal?
|
|
'((3 . 4) 3 . 4)
|
|
(letrec ([a (letrec* ([b (lambda () c)] [d 0]) b)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)]) (cons (m) n))))
|
|
|
|
(equal?
|
|
'((1 . 2) (3 . 4) 3 . 4)
|
|
(letrec ([a (letrec* ([b (lambda () (lambda () c))] [d (b)]) d)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)])
|
|
(cons c (cons (m) n)))))
|
|
|
|
(error? ; undefined variable b
|
|
(letrec ([a
|
|
(letrec ([b (lambda () (lambda () c))] [d (b)]) d)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)])
|
|
(cons c (cons (m) n)))))
|
|
|
|
(error? ; undefined variable b
|
|
(letrec ([a (letrec ([b (lambda () (lambda () c))] [d ((b))]) d)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)])
|
|
(cons c (cons (m) n)))))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec ([a (letrec* ([b (lambda () (lambda () c))] [d ((b))]) d)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons 3 4)])
|
|
(cons c (cons (m) n)))))
|
|
|
|
(equal?
|
|
'((1 . 2) ((1 . 2) . 4) (1 . 2) . 4)
|
|
(letrec ([a (letrec* ([b (lambda () (lambda () c))] [d (b)]) d)]
|
|
[c (cons 1 2)])
|
|
(letrec* ([m (lambda () n)] [n (cons c 4)])
|
|
(cons (a) (cons (m) n)))))
|
|
|
|
(equal? '(1 . 2)
|
|
(letrec* ([m (let ([f (lambda () n)]) f)][n (cons 1 2)]) n))
|
|
|
|
(error? ; undefined variable n
|
|
(letrec* ([m (let ([f (lambda () n)]) (f))]
|
|
[n (cons 1 2)])
|
|
n))
|
|
|
|
(eqv? #f
|
|
(letrec* ([a (lambda (n) (n 0))]
|
|
[b (a (lambda (x) (if (zero? x) #f c)))]
|
|
[c #t])
|
|
b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda (n) (n 0))]
|
|
[b (a (lambda (x) (if (zero? x) c #f)))]
|
|
[c #t])
|
|
b))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (letrec ([b (letrec ([c (lambda () a)]) (c))])
|
|
(lambda () b))])
|
|
((lambda () c))))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda (f g) (f g))][b (lambda (x) c)][c (b b)]) (list a b c)))
|
|
|
|
(error? ; undefined variable m
|
|
(letrec ([m (lambda (x) (cons n x))] [n ((lambda () m))])
|
|
(m '())))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (lambda () 0)]
|
|
[b (zero? (a))]
|
|
[c (if b (a) a)])
|
|
c))
|
|
|
|
(error? ; undefined variable y
|
|
(letrec ([x (lambda () y)] [y (lambda (f) (f))] [z (y (lambda () (x)))])
|
|
(z (lambda () 3))))
|
|
|
|
(eq? 3
|
|
(letrec* ([x (lambda (f) (f))]
|
|
[y (lambda () x)]
|
|
[z (x y)])
|
|
(z (lambda () 3))))
|
|
|
|
(eq? 3
|
|
(letrec ([x (lambda (f) (f))]
|
|
[y (lambda () x)]
|
|
[z (lambda () (x y))])
|
|
((z) (lambda () 3))))
|
|
|
|
#;(error? ; undefined variable y
|
|
(letrec ([x (lambda () y)]
|
|
[y (lambda (f) (f))]
|
|
[z (call/cc (lambda (k) (y (lambda () (x)))))]) ; invalid in r6rs
|
|
((z) (lambda () 3))))
|
|
|
|
#;(eq? 3
|
|
(letrec ([x (lambda (f) (f))]
|
|
[y (lambda () x)]
|
|
[z (call/cc (lambda (k) (lambda () (x y))))]) ; invalid in r6rs
|
|
((z) (lambda () 3))))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a 3]
|
|
[b (letrec* ([c (lambda () a)] [d (c)]) (* d d))])
|
|
(* a b)))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a 3]
|
|
[b (letrec* ([c (lambda () (lambda () a))] [d (c)])
|
|
(* (d) (d)))])
|
|
(* a b)))
|
|
|
|
(eq? 9
|
|
(letrec ([a 3] [b (letrec* ([c (lambda () (lambda () a))] [d (c)]) d)])
|
|
(* a (b))))
|
|
|
|
(eq? 27
|
|
(letrec ([a 3]
|
|
[b (lambda () (letrec* ([c (lambda () (lambda () a))]
|
|
[d (c)])
|
|
(* (d) (d))))])
|
|
(* a (b))))
|
|
|
|
|
|
#;(error? ; undefined variable b
|
|
(letrec* ([a (call/cc (lambda (k) (lambda (n) (if (zero? n) k b))))]
|
|
[b ((a 0) (a 10))]) ; invalid in r6rs
|
|
b))
|
|
)
|
|
|
|
(mat cpvalid
|
|
(error? (letrec ([a (lambda () c)] [b (a)] [c 4]) b))
|
|
(error? (letrec* ([a (lambda () c)] [b (a)] [c 4]) b))
|
|
(error? (letrec ([f (lambda () (g))] [h (f)] [g (lambda () 3)]) h))
|
|
(error? (letrec* ([f (lambda () (g))] [h (f)] [g (lambda () 3)]) h))
|
|
(error? (letrec ([a (set! b 0)] [b 3]) b))
|
|
(error? (letrec ([b 3] [a (set! b 723)]) b))
|
|
(error? (letrec* ([a (set! b 0)] [b 3]) b))
|
|
(eqv? (letrec* ([b 3] [a (set! b 723)]) b) 723)
|
|
(error? (letrec ([a (lambda () c)]
|
|
[b (let ((f (lambda () (a)))) (f))]
|
|
[c 44])
|
|
(list (a) b c)))
|
|
(error? (letrec* ([a (lambda () c)]
|
|
[b (let ((f (lambda () (a)))) (f))]
|
|
[c 44])
|
|
(list (a) b c)))
|
|
(error? (letrec ([a (lambda () c)]
|
|
[b (let ((f (lambda () a))) (f))]
|
|
[c 44])
|
|
(list (a) (b) c)))
|
|
(equal? (letrec* ([a (lambda () c)]
|
|
[b (let ((f (lambda () a))) (f))]
|
|
[c 44])
|
|
(list (a) (b) c))
|
|
'(44 44 44))
|
|
(equal? (letrec ([a (cons (lambda () b) (lambda () c))]
|
|
[b (cons (lambda () a) (lambda () c))]
|
|
[c (cons (lambda () a) (lambda () b))]
|
|
[d (list (lambda () d))])
|
|
(map pair? (list ((car a)) ((cdr b)) c ((car d)))))
|
|
'(#t #t #t #t))
|
|
(equal? (letrec* ([a (cons (lambda () b) (lambda () c))]
|
|
[b (cons (lambda () a) (lambda () c))]
|
|
[c (cons (lambda () a) (lambda () b))]
|
|
[d (list (lambda () d))])
|
|
(map pair? (list ((car a)) ((cdr b)) c ((car d)))))
|
|
'(#t #t #t #t))
|
|
(error? (letrec ([a (letrec ([b (lambda () (c))]
|
|
[c (lambda () a)]
|
|
[d (lambda () (b))])
|
|
(d))])
|
|
(a 55)))
|
|
(error? (letrec ([a (letrec* ([b (lambda () (c))]
|
|
[c (lambda () a)]
|
|
[d (lambda () (b))])
|
|
(d))])
|
|
(a 55)))
|
|
(error? (letrec ([a (letrec ([b (lambda () (c))]
|
|
[c (lambda () a)]
|
|
[d (b)])
|
|
(d))])
|
|
(a 55)))
|
|
(error? (letrec ([a (letrec* ([b (lambda () (c))]
|
|
[c (lambda () a)]
|
|
[d (b)])
|
|
(d))])
|
|
(a 55)))
|
|
(eqv? (letrec* ([b (lambda () (c))]
|
|
[c (lambda () 73)]
|
|
[d (b)])
|
|
d)
|
|
73)
|
|
(procedure?
|
|
(let ()
|
|
(define f (rec f* (lambda () (g))))
|
|
(define g (rec g* (lambda () (f))))
|
|
g))
|
|
(equal?
|
|
(let ([q #f])
|
|
(letrec ((a (letrec ((f (lambda () a)) (g (lambda () (set! q "hi\n"))))
|
|
(g)
|
|
(lambda () (f)))))
|
|
(list (eq? a (a)) q)))
|
|
'(#t "hi\n"))
|
|
(error? ; should complain about g
|
|
(let ()
|
|
(define f (letrec ((f* (lambda () (g)))) (f*)))
|
|
(define g (letrec ((g* (lambda () (f)))) (g*)))
|
|
g))
|
|
(internal-defines-as-letrec*)
|
|
(begin (internal-defines-as-letrec* #f) (not (internal-defines-as-letrec*)))
|
|
(error? ; might complain about f or g
|
|
(let ()
|
|
(define f (letrec ((f* (lambda () (g)))) (f*)))
|
|
(define g (letrec ((g* (lambda () (f)))) (g*)))
|
|
g))
|
|
(begin (internal-defines-as-letrec* #t) (internal-defines-as-letrec*))
|
|
(error?
|
|
(letrec* ((a (lambda () (c)))
|
|
(b (lambda () (d)))
|
|
(c (lambda () (f)))
|
|
(d (lambda () (f)))
|
|
(e (cons (a) (lambda () (b))))
|
|
(f ((cdr e))))
|
|
7))
|
|
(error?
|
|
(letrec* ((a (lambda () (b)))
|
|
(b (lambda () (c)))
|
|
(c (a)))
|
|
7))
|
|
; verify that cpletrec output is straight rec-binding:
|
|
(equal? (letrec* ((e (lambda (x) (or (= x 0) (o (- x 1)))))
|
|
(o (lambda (x) (and (not (= x 0)) (e (- x 1))))))
|
|
(list (e 7) (o 7) (e 6) (o 6)))
|
|
'(#f #t #t #f))
|
|
; verify that cpletrec output is straight rec-binding:
|
|
(letrec ([a (letrec* ([b (lambda () (c))]
|
|
[c (lambda () a)]
|
|
[d (lambda () (b))])
|
|
(lambda () (d)))])
|
|
(eq? a (a)))
|
|
; check for warnings when requested
|
|
(eq?
|
|
(parameterize ([undefined-variable-warnings "yes please!"])
|
|
(undefined-variable-warnings))
|
|
#t)
|
|
(warning? ; possible undefined variable
|
|
(parameterize ([undefined-variable-warnings #t] [optimize-level 2])
|
|
(eval '(let () (define x x) x))))
|
|
(error? ; undefined variable
|
|
(parameterize ([undefined-variable-warnings #f] [optimize-level 2])
|
|
(eval '(let () (define x x) x))))
|
|
(begin
|
|
(with-output-to-file "testfile.ss"
|
|
(lambda () (pretty-print '(let () (define x x) (x y))))
|
|
'replace)
|
|
#t)
|
|
(warning? ; possible undefined variable, with source info
|
|
(parameterize ([undefined-variable-warnings #t] [optimize-level 2])
|
|
(compile-file "testfile")))
|
|
(error? ; undefined variable, with source info
|
|
(parameterize ([undefined-variable-warnings #f] [optimize-level 2])
|
|
(compile-file "testfile")
|
|
(load "testfile.so")))
|
|
)
|
|
|
|
(mat cpvalid2 ; from Dipa
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)] [b (a)] [c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)][b (let ((d a)) (d))][c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (let ([d (lambda () c)]) (d))][b a][c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (letrec* ([b (lambda () c)][d (b)][c (cons 1 2)]) d)]) a))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)][b (lambda (f) (f))][d (b a)][c (cons 1 2)]) d))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)][b (lambda () a)][d ((b))][c (cons 1 2)]) d))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () (set! c d))][b (a)][c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () (set! d c))][b (a)][c (cons 1 2)]) d))
|
|
|
|
(equal?
|
|
(letrec* ([a (lambda () c)]
|
|
[b (if #t a (a))]
|
|
[c (cons 1 2)])
|
|
(b))
|
|
'(1 . 2))
|
|
|
|
(error? ; undefined variable c
|
|
(letrec* ([a (lambda () c)][b (if #t (a) a)][c (cons 1 2)]) b))
|
|
|
|
(error? ; undefined variable a
|
|
(letrec ([a (letrec* ([b (lambda () a)]) (b))][c (cons 1 2)]) (cons a c)))
|
|
)
|
|
|
|
(mat rec
|
|
(let ((f (rec g (lambda () g)))) (eq? f (f)))
|
|
(let ((f (rec g (lambda (x) (if (zero? x) 1 (* x (g (1- x))))))))
|
|
(= (f 4) 24))
|
|
)
|
|
|
|
(mat define
|
|
(begin (define xxxx 'xxxxval) #t)
|
|
(and (top-level-bound? 'xxxx) (eqv? (top-level-value 'xxxx) 'xxxxval))
|
|
(begin (define (ffff x) (+ x x)) #t)
|
|
(and (top-level-bound? 'ffff) (eqv? ((top-level-value 'ffff) 17) 34))
|
|
(begin (define (eeee . l) l) #t)
|
|
(equal? (eeee 1 2 3) '(1 2 3))
|
|
(begin (define (dddd x . l) (cons x l)) #t)
|
|
(equal? (dddd 1 2 3 4) '(1 2 3 4))
|
|
((lambda (x)
|
|
(define yyyy x)
|
|
(define (gggg y) (+ yyyy y))
|
|
(and (not (top-level-bound? 'yyyy))
|
|
(not (top-level-bound? 'gggg))
|
|
(eqv? (gggg 22) 25)))
|
|
3)
|
|
(let ((x 3))
|
|
(define yyyy x)
|
|
(define (gggg y) (+ yyyy y))
|
|
(and (not (top-level-bound? 'yyyy))
|
|
(not (top-level-bound? 'gggg))
|
|
(eqv? (gggg 22) 25)))
|
|
(let* ((x 3))
|
|
(define yyyy x)
|
|
(define (gggg y) (+ yyyy y))
|
|
(and (not (top-level-bound? 'yyyy))
|
|
(not (top-level-bound? 'gggg))
|
|
(eqv? (gggg 22) 25)))
|
|
(letrec ((x 3))
|
|
(define yyyy x)
|
|
(define (gggg y) (+ yyyy y))
|
|
(and (not (top-level-bound? 'yyyy))
|
|
(not (top-level-bound? 'gggg))
|
|
(eqv? (gggg 22) 25)))
|
|
(let ()
|
|
(begin (define x 3) (define y 4))
|
|
(begin)
|
|
(begin (define z 5))
|
|
(= (+ (* x x) (* y y)) (* z z)))
|
|
(error? (lambda () 0 (define x 3) x))
|
|
(error? (lambda () 0 (begin (define x 3)) x))
|
|
(error? (lambda () 0 (begin) x))
|
|
(error? (case-lambda [() 0 (define x 3) x]))
|
|
(error? (let () 0 (define x 3) x))
|
|
(error? (let* () 0 (define x 3) x))
|
|
(error? (letrec () 0 (define x 3) x))
|
|
(error? (if (define x 3) x x))
|
|
)
|
|
|
|
(mat define-values
|
|
(begin (define-values ($dv-x $dv-y) (values 'a 'b)) #t)
|
|
(eq? $dv-x 'a)
|
|
(eq? $dv-y 'b)
|
|
(begin (define-values $dv-r (values)) #t)
|
|
(equal? $dv-r '())
|
|
(begin (define-values $dv-r (values 1)) #t)
|
|
(equal? $dv-r '(1))
|
|
(begin (define-values $dv-r (values 1 2 3 4 5)) #t)
|
|
(equal? $dv-r '(1 2 3 4 5))
|
|
(begin (define-values ($dv-x $dv-y . $dv-r) (values 1 2 3 4 5)) #t)
|
|
(eqv? $dv-x 1)
|
|
(eqv? $dv-y 2)
|
|
(equal? $dv-r '(3 4 5))
|
|
(begin (define-values ($dv-x $dv-y) (div-and-mod 19 4)) #t)
|
|
(eqv? $dv-x 4)
|
|
(eqv? $dv-y 3)
|
|
(begin (define-values ($dv-x $dv-y . $dv-z) (div-and-mod 19 4)) #t)
|
|
(eqv? $dv-x 4)
|
|
(eqv? $dv-y 3)
|
|
(equal? $dv-z '())
|
|
(error? ; invalid number of arguments
|
|
(define-values ($dv-x . $dv-r) (values)))
|
|
(error? ; invalid number of arguments
|
|
(define-values ($dv-x $dv-y . $dv-r) (values)))
|
|
(error? ; invalid number of arguments
|
|
(define-values ($dv-x $dv-y . $dv-r) (values 1)))
|
|
(error? ; invalid number of arguments
|
|
(define-values ($dv-x $dv-y $dv-z . $dv-r) (div-and-mod 19 4)))
|
|
(error? ; invalid number of arguments
|
|
(define-values ($dv-x) (div-and-mod 19 4)))
|
|
(error? ; invalid number of arguments
|
|
(define-values () (div-and-mod 19 4)))
|
|
(error? ; duplicate variable name
|
|
(define-values ($dv-x $dv-x) (div-and-mod 19 4)))
|
|
(error? ; duplicate variable name
|
|
(define-values ($dv-x . $dv-x) (div-and-mod 19 4)))
|
|
(equal?
|
|
(let ()
|
|
(define-values (x y) (values 'a 'b))
|
|
(list x y))
|
|
'(a b))
|
|
(equal?
|
|
(let ()
|
|
(define-values r (values))
|
|
r)
|
|
'())
|
|
(equal?
|
|
(let ()
|
|
(module (r)
|
|
(define-values r (values 1)))
|
|
r)
|
|
'(1))
|
|
(equal?
|
|
(let ()
|
|
(define-values r (values 1 2 3 4 5))
|
|
r)
|
|
'(1 2 3 4 5))
|
|
(equal?
|
|
(let ()
|
|
(define-values (x y . r) (values 1 2 3 4 5))
|
|
(vector x y r))
|
|
'#(1 2 (3 4 5)))
|
|
(equal?
|
|
(let ()
|
|
(define-values (x y) (div-and-mod 19 4))
|
|
(list y x))
|
|
'(3 4))
|
|
(equal?
|
|
(let ()
|
|
(define-values (x y . z) (div-and-mod 19 4))
|
|
(vector z x y))
|
|
'#(() 4 3))
|
|
(error? ; invalid number of arguments
|
|
(let ()
|
|
(define-values (x . r) (values))
|
|
r))
|
|
(error? ; no expressions in body
|
|
(let ()
|
|
(define-values (x y . r) (values))))
|
|
(error? ; invalid number of arguments
|
|
(let ()
|
|
(define-values (x y . r) (values 1))
|
|
x))
|
|
(error? ; invalid number of arguments
|
|
(let ()
|
|
(define-values (x y z . r) (div-and-mod 19 4))
|
|
x))
|
|
(error? ; invalid number of arguments
|
|
(let ()
|
|
(define-values (x) (div-and-mod 19 4))
|
|
x))
|
|
(error? ; invalid number of arguments
|
|
(let ()
|
|
(define-values () (div-and-mod 19 4))
|
|
#t))
|
|
(error? ; duplicate variable name
|
|
(let ()
|
|
(define-values (x x) (div-and-mod 19 4))
|
|
x))
|
|
(error? ; duplicate variable name
|
|
(let ()
|
|
(define-values (x . x) (div-and-mod 19 4))
|
|
x))
|
|
(begin
|
|
(library ($dv-foo) (export $dv-foo-x) (import (chezscheme))
|
|
(define-values $dv-foo-x (div-and-mod 19 4)))
|
|
#t)
|
|
(equal?
|
|
(let () (import ($dv-foo)) $dv-foo-x)
|
|
'(4 3))
|
|
(begin (import ($dv-foo)) #t)
|
|
(equal? $dv-foo-x '(4 3))
|
|
(begin
|
|
(library ($dv-foo1) (export $dv-foo1-x) (import (chezscheme))
|
|
(define-values ($dv-foo1-x . r) (values)))
|
|
#t)
|
|
(error? ; invalid number of arguments
|
|
(let () (import ($dv-foo1)) $dv-foo1-x))
|
|
(error? ; duplicate variable name
|
|
(library ($dv-foo2) (export $dv-foo2-x) (import (chezscheme))
|
|
(define-values ($dv-foo2-x . $dv-foo2-x) (values))
|
|
$dv-foo2-x))
|
|
; make sure pattern variables and ellipses on RHS don't screw us up
|
|
(eqv?
|
|
(let ()
|
|
(define-syntax q
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
|
|
(define-values (a) (q ...))
|
|
a)
|
|
3)
|
|
(equal?
|
|
(let ()
|
|
(define-syntax q
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
|
|
(define-values a (q ...))
|
|
a)
|
|
'(3))
|
|
(equal?
|
|
(let ()
|
|
(define-syntax q
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
|
|
(define-values (a . b) (q ...))
|
|
(list a b))
|
|
'(3 ()))
|
|
(equal?
|
|
(syntax-case '(a b c) ()
|
|
[(x ...)
|
|
(let ()
|
|
(define-values (args) #'(x ...))
|
|
args)])
|
|
'(a b c))
|
|
(equal?
|
|
(syntax-case '(a b c) ()
|
|
[(x ...)
|
|
(let ()
|
|
(define-values (args . rot) (values #'(x ...) #'(x ...) 3))
|
|
(list args rot))])
|
|
'((a b c) ((a b c) 3)))
|
|
(equal?
|
|
(let ()
|
|
(define x 1)
|
|
(define-values ()
|
|
(begin
|
|
"don't interrupt definitions"
|
|
(values)))
|
|
(define y 2)
|
|
(list x y))
|
|
'(1 2))
|
|
)
|
|
|
|
(mat assimilation
|
|
(syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
[optimize-level 2])
|
|
(expand/optimize
|
|
'(letrec* ([x (let ([y 0])
|
|
(lambda ()
|
|
(set! y (- y 1))
|
|
y))]
|
|
[z (lambda () (x))])
|
|
(z)
|
|
(x))))
|
|
(lambda set! - $primitive)
|
|
[(let ([y1 0])
|
|
(set! y2 (#2%- y3 1))
|
|
(set! y4 (#2%- y5 1))
|
|
y6)
|
|
#t]
|
|
[_ #f])
|
|
(syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
[optimize-level 2])
|
|
(expand/optimize
|
|
'(letrec ([x (let ([y 0])
|
|
(lambda ()
|
|
(set! y (- y 1))
|
|
y))]
|
|
[z (lambda () (x))])
|
|
(z)
|
|
(x))))
|
|
(lambda set! - $primitive)
|
|
[(let ([y1 0])
|
|
(set! y2 (#2%- y3 1))
|
|
(set! y4 (#2%- y5 1))
|
|
y6)
|
|
#t]
|
|
[_ #f])
|
|
(syntax-case (parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
|
|
[#%$suppress-primitive-inlining #f]
|
|
[optimize-level 2])
|
|
(expand/optimize
|
|
'(letrec* ([w 15]
|
|
[x (let ([y w])
|
|
(lambda ()
|
|
(set! y (- y 1))
|
|
y))]
|
|
[z (lambda () (x))])
|
|
(z)
|
|
(x))))
|
|
(lambda set! - $primitive)
|
|
[(let ([y1 15])
|
|
(set! y2 (#2%- y3 1))
|
|
(set! y4 (#2%- y5 1))
|
|
y6)
|
|
#t]
|
|
[_ #f])
|
|
(equal?
|
|
(let ([f (letrec ([e? (lambda (x) (or (zero? x) (o? (- x 1))))]
|
|
[o? (lambda (x) (not (e? x)))])
|
|
(lambda (a b) (vector (e? a) (e? b) (o? a) (o? b))))])
|
|
(f 3 0))
|
|
'#(#f #t #t #f))
|
|
(equal?
|
|
(let ([f (letrec ([q? (lambda (x) (not (p? x)))]
|
|
[p? (lambda (x) (> x 0))])
|
|
(lambda (a b) (vector (p? a) (p? b) (q? a) (q? b))))])
|
|
(f 3 -3))
|
|
'#(#t #f #f #t))
|
|
(equal?
|
|
(let ([f (letrec* ([x 5] [y (+ x x)])
|
|
(lambda ()
|
|
(set! x (+ x y))
|
|
(set! y (+ y x))
|
|
(cons x y)))])
|
|
(let ([t (f)]) (list t (f))))
|
|
'((15 . 25) (40 . 65)))
|
|
(equal?
|
|
(letrec ([f (letrec* ([g (lambda (x)
|
|
(lambda (y)
|
|
(if (= x y) 0 (+ 2 (h (- y 1))))))]
|
|
[x0 17]
|
|
[h (g x0)])
|
|
(lambda (y1 y2) (cons (h y1) (h y2))))])
|
|
(list (f 20 25) (f 28 31)))
|
|
'((6 . 16) (22 . 28)))
|
|
(equal?
|
|
(letrec ([f (letrec* ([g (lambda (n f)
|
|
(if (= n 0)
|
|
f
|
|
(g (- n 1) (lambda (m) (f (+ m 1))))))]
|
|
[q 7]
|
|
[h (g q (lambda (x) (* x 2)))])
|
|
(lambda (y1 y2 y3) (list (h y1) (h y2) ((g 5 values) 7))))])
|
|
(vector (f 1 2 3) (f 4 5 6)))
|
|
'#((16 18 12) (22 24 12)))
|
|
(equal?
|
|
(letrec ([f (letrec* ([g (values
|
|
(lambda (n f)
|
|
(if (= n 0)
|
|
f
|
|
(g (- n 1) (lambda (m) (f (+ m 1)))))))]
|
|
[q 7]
|
|
[h (g q (lambda (x) (* x 2)))])
|
|
(lambda (y1 y2 y3) (list (h y1) (h y2) ((g 5 values) 7))))])
|
|
(vector (f 1 2 3) (f 4 5 6)))
|
|
'#((16 18 12) (22 24 12)))
|
|
(equal?
|
|
(letrec ([f (letrec* ([g (lambda (n f)
|
|
(if (= n 0)
|
|
f
|
|
(g (- n 1) (lambda (m) (f (+ m 1))))))]
|
|
[g^ g]
|
|
[g^^ g^])
|
|
(lambda (y1 y2 y3)
|
|
(when #f (set! g 0) (set! g^ 1) (set! g^^ 2))
|
|
(list ((g y1 values) y2)
|
|
((g^ y2 (lambda (x) (* x x))) y3)
|
|
((g^^ y3 (lambda (x) (- x))) y1))))])
|
|
(vector (f 1 2 3) (f 4 5 6)))
|
|
'#((3 25 -4) (9 121 -10)))
|
|
)
|
|
|
|
(mat set!
|
|
(begin (set! foo 'hello) (eq? foo 'hello))
|
|
(let ([x 'a]) (set! x 'b) (eq? x 'b))
|
|
(let ([x 'a])
|
|
(let ([f (lambda () (set! x 'b))])
|
|
(and (eq? x 'a) (begin (f) (eq? x 'b)))))
|
|
; test gensym set!/reference
|
|
(equal? (begin (set! #0=#{a |pig|} '#0#) (set! #1=#{b |sty|} #0#) #1#) '#0#)
|
|
)
|
|
|
|
(mat fluid-let
|
|
(fluid-let () #t)
|
|
(eq? (fluid-let () (define x 4) x) 4)
|
|
(let* ((x 'a) (f (lambda () x)))
|
|
(and
|
|
(fluid-let ((x 'b))
|
|
(and (eq? x 'b) (eq? (f) 'b)))
|
|
(eq? x 'a)
|
|
(eq? (f) 'a)))
|
|
(let* ((x 'a) (f (lambda () x)))
|
|
(and
|
|
(call/cc
|
|
(lambda (return)
|
|
(fluid-let ((x 'b))
|
|
(return (and (eq? x 'b) (eq? (f) 'b))))))
|
|
(eq? x 'a)
|
|
(eq? (f) 'a)))
|
|
(equal?
|
|
(let* ((x 'a) (f (lambda () x)))
|
|
((call/cc
|
|
(lambda (return)
|
|
(fluid-let ((x 'b))
|
|
(call/cc
|
|
(lambda (back)
|
|
(return back)))
|
|
(let ((ans (f))) (lambda (y) (list ans x))))))
|
|
'()))
|
|
'(b a))
|
|
(eqv?
|
|
(let ([x 75])
|
|
(fluid-let ([x 23] [x 23]) 0)
|
|
x)
|
|
75)
|
|
)
|
|
|
|
;(mat variable
|
|
; (eq? (fluid-let ([car 3])
|
|
; ((parameterize ([optimize-level 2])
|
|
; (eval '(lambda () car)))))
|
|
; car)
|
|
; (eq? (fluid-let ([car 3])
|
|
; ((parameterize ([$compiling-system-code #t])
|
|
; (eval '(lambda () car)))))
|
|
; car)
|
|
; (eq? ((parameterize ([$compiling-system-code #t])
|
|
; (eval '(lambda () $oblist))))
|
|
; (parameterize ([$compiling-system-code #t])
|
|
; (eval '$oblist)))
|
|
; (error? ((parameterize ([optimize-level 2])
|
|
; (eval '(lambda () (set! car 3))))))
|
|
; )
|
|
|
|
(mat mrvs
|
|
(error?
|
|
(values))
|
|
(error?
|
|
(if (values 1 2 3) 4 5))
|
|
(error?
|
|
(values 1 2 3))
|
|
(eq?
|
|
(values 2)
|
|
2)
|
|
(eq?
|
|
(let ((f (lambda () (values))))
|
|
(+ 2 (call-with-values f (lambda () 5))))
|
|
7)
|
|
(error?
|
|
(let ((f (lambda () (values)))) (+ 2 (f))))
|
|
(eq?
|
|
(call-with-values
|
|
(lambda () (begin 5 (values 2 3)))
|
|
(lambda (x y) (+ x y)))
|
|
5)
|
|
(error?
|
|
(call-with-values
|
|
(lambda () (begin 5 (values 2)))
|
|
(lambda (x y) (+ x y))))
|
|
(eq?
|
|
(call-with-values
|
|
(lambda () (begin 5 (values 1 2)))
|
|
(lambda (x y) (+ x y)))
|
|
3)
|
|
(eq?
|
|
(call-with-values
|
|
(lambda () (values 2 3))
|
|
(lambda (x y) (+ x y)))
|
|
5)
|
|
(equal?
|
|
(let ((f (lambda () (values 2 3)))
|
|
(g (lambda (x y) (cons x y))))
|
|
(call-with-values f g))
|
|
'(2 . 3))
|
|
(eq?
|
|
(let ((f (lambda () (lambda () (values 2 3))))
|
|
(g (lambda (x) x)))
|
|
(call-with-values (call-with-values f g) +))
|
|
5)
|
|
(eq?
|
|
(let ((f (lambda () (lambda () (values 2 3)))))
|
|
(call-with-values (car (call-with-values f list)) +))
|
|
5)
|
|
(equal?
|
|
(cons 1 (let ((f (lambda () (values 2 3)))) (call-with-values f list)))
|
|
'(1 2 3))
|
|
(eq?
|
|
(let ((f (lambda (g h) (+ 1 (call-with-values g h)))))
|
|
(f (lambda () (values 1 2))
|
|
(lambda (x y) (+ x y))))
|
|
4)
|
|
(eq?
|
|
(let ((f (lambda (f g) (call-with-values f g))))
|
|
(f (lambda () (call/cc (lambda (k) (values 5 k))))
|
|
(lambda (x k) (if (= x 5) (k 0 k) 1))))
|
|
1)
|
|
(eq?
|
|
(+ 2 (call/cc
|
|
(lambda (k)
|
|
(let ((f (lambda () (k 5))))
|
|
(call-with-values f list)))))
|
|
7)
|
|
(eq?
|
|
(let ((f (lambda ()
|
|
(let ((f (lambda (f g) (call-with-values f g))))
|
|
(f (lambda ()
|
|
(call/cc
|
|
(lambda (k)
|
|
(values 0 k))))
|
|
(lambda (x k)
|
|
(call/cc
|
|
(lambda (k1)
|
|
(k 1 k1))))))))
|
|
(g (lambda (x y) x)))
|
|
(call-with-values f g))
|
|
1)
|
|
(bignum?
|
|
(letrec ((f (lambda (x)
|
|
(if (= x 0)
|
|
(values 1 0 0)
|
|
(let ((g (lambda (u v w)
|
|
(values (* x u) (+ v 1) (+ w 2)))))
|
|
(call-with-values
|
|
(lambda () (f (- x 1)))
|
|
g))))))
|
|
(let ((h (lambda (x y z) x)))
|
|
(call-with-values
|
|
(lambda () (f 2000))
|
|
h))))
|
|
(equal?
|
|
(let ((h (lambda (x) (lambda (y z) (list x y z))))
|
|
(g (lambda (x) (lambda () (values x 3)))))
|
|
(cons 0 (call-with-values (g 2) (h 1))))
|
|
'(0 1 2 3))
|
|
(eqv? (call-with-values (lambda () (apply values (make-list 1000 1))) +)
|
|
1000)
|
|
(equal? (call-with-values (lambda () (if (random 10) 2 3)) list)
|
|
'(2))
|
|
(equal? (call-with-values (case-lambda (x x) (() 3)) list) '(()))
|
|
(eqv? (let ([f (lambda () (values 1 2 3))])
|
|
(+ 2 (call-with-values f (lambda x (length x)))))
|
|
5)
|
|
(equal? (let ((x list)) (call-with-values (lambda () (set! x +) 3) x))
|
|
'(3))
|
|
(error? (call-with-values values (lambda (x) x)))
|
|
(error? (call-with-values values (lambda (x y) x)))
|
|
(error? (let ((f values)) (call-with-values f (lambda (x y) x))))
|
|
(equal?
|
|
(let ()
|
|
(define f
|
|
(lambda (a b c)
|
|
(call-with-values
|
|
(let ((x values)) (lambda () (x 1 2)))
|
|
(lambda (d e)
|
|
(list a b c d e)))))
|
|
(f 3 4 5))
|
|
'(3 4 5 1 2))
|
|
(eqv?
|
|
(let ()
|
|
(define f1
|
|
(lambda (x) (values 1 0)))
|
|
(define f2
|
|
(lambda (a)
|
|
(vector-ref a 0)
|
|
(call-with-values
|
|
(lambda () (f1 a))
|
|
(lambda (d e) d))))
|
|
(f2 '#(a)))
|
|
1)
|
|
(equal?
|
|
(let ()
|
|
(define f1 (lambda (x) (lambda () (values 1 2))))
|
|
(define f2
|
|
(lambda (a)
|
|
(random 10)
|
|
(call-with-values
|
|
(f1 a)
|
|
(lambda (x y)
|
|
(random 20)
|
|
(list a x y)))))
|
|
(f2 0))
|
|
'(0 1 2))
|
|
(null? (call-with-values
|
|
(lambda () (call/cc (lambda (k) (values))))
|
|
(lambda args args)))
|
|
(null? (call-with-values
|
|
(lambda () (call/cc (lambda (k) (k))))
|
|
(lambda args args)))
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (call/cc (lambda (k) (k 'a 'b 'c))))
|
|
(lambda args args))
|
|
'(a b c))
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (call/cc (lambda (k) (values 'a 'b 'c))))
|
|
(lambda args args))
|
|
'(a b c))
|
|
(null? (call-with-values
|
|
(lambda () (dynamic-wind values values values))
|
|
list))
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (call/cc (lambda (k) (values 1 2 3 4 5 6 7 8 9 10))))
|
|
list)
|
|
'(1 2 3 4 5 6 7 8 9 10))
|
|
(eqv?
|
|
(letrec ((z 2)
|
|
(f (lambda () (values 1 z)))
|
|
(g (lambda (x y) (values x y z))))
|
|
(call-with-values
|
|
(lambda ()
|
|
(call-with-values
|
|
f
|
|
(lambda (z b) (g z b))))
|
|
(lambda (c d e)
|
|
(+ c d e z))))
|
|
7)
|
|
(or (= (optimize-level) 3)
|
|
(guard (c [(not (warning? c)) (collect) #t])
|
|
(if (call-with-values
|
|
current-output-port
|
|
(lambda (v out) (current-output-port)))
|
|
1
|
|
2)))
|
|
(equal?
|
|
(let ()
|
|
(define split
|
|
(lambda (ls)
|
|
(if (or (null? ls) (null? (cdr ls)))
|
|
(values ls '())
|
|
(call-with-values
|
|
(lambda () (split (cddr ls)))
|
|
(lambda (odds evens)
|
|
(values (cons (car ls) odds)
|
|
(cons (cadr ls) evens)))))))
|
|
(call-with-values
|
|
(lambda () (split '(a b c d e f)))
|
|
vector))
|
|
'#((a c e) (b d f)))
|
|
|
|
; test chains of consumers
|
|
(begin
|
|
(define-syntax $mrvs-a
|
|
(syntax-rules ()
|
|
[(_) ($mrvs-f0)]
|
|
[(_ f1 f2 ...)
|
|
(let ([f1 (lambda (a b c d) (values d a b c))])
|
|
(call-with-values (lambda () ($mrvs-a f2 ...)) f1))]))
|
|
(define $mrvs-f0 (lambda () (values 1 2 3 4)))
|
|
(define $mrvs-list (lambda args args))
|
|
#t)
|
|
|
|
; test chains of consumers ending in a non-tail call
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-a)) $mrvs-list)
|
|
'(1 2 3 4))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-a f1)) $mrvs-list)
|
|
'(4 1 2 3))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-a f1 f2 f3 f4)) $mrvs-list)
|
|
'(1 2 3 4))
|
|
|
|
; test chains of consumers ending in a tail call
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-a)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-a f1)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(4 1 2 3))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-a f1 f2 f3 f4)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(call-with-values (lambda () ($mrvs-a f1 f2 f3)) foo)))
|
|
#t)
|
|
(equal? ($mrvs-q $mrvs-list) '(2 3 4 1))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-a f1 f2 f3)) foo))))
|
|
#t)
|
|
(equal? (($mrvs-q $mrvs-list)) '(2 3 4 1))
|
|
|
|
; test chains of consumers ending in a let-values
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-a)]) (cons r a))
|
|
'((2 3 4) . 1))
|
|
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-a f1)]) (cons r a))
|
|
'((1 2 3) . 4))
|
|
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-a f1 f2 f3 f4)]) (cons r a))
|
|
'((2 3 4) . 1))
|
|
|
|
; test chains of consumers ending in a let-values-like call-with-values
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-a))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((3 4) 2 . 1))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-a f1))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((2 3) 1 . 4))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-a f1 f2 f3 f4))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((3 4) 2 . 1))
|
|
|
|
; test chains of consumers w/fi as free variables
|
|
(begin
|
|
(define-syntax $mrvs-a
|
|
(syntax-rules ()
|
|
[(_ f ...)
|
|
(let ([x 17])
|
|
(let ([f (lambda (y a b c d) (values x d a b c))] ...)
|
|
(set! x (* x 4))
|
|
(lambda () ($mrvs-b f ...))))]))
|
|
(define-syntax $mrvs-b
|
|
(syntax-rules ()
|
|
[(_) ($mrvs-f0)]
|
|
[(_ f1 f2 ...) (call-with-values (lambda () ($mrvs-b f2 ...)) f1)]))
|
|
(define $mrvs-f0 (lambda () (values 0 1 2 3 4)))
|
|
(define $mrvs-list (lambda args args))
|
|
#t)
|
|
|
|
; test chains of consumers ending in a non-tail call
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-a))) $mrvs-list)
|
|
'(0 1 2 3 4))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-a f1))) $mrvs-list)
|
|
'(68 4 1 2 3))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-a f1 f2 f3 f4))) $mrvs-list)
|
|
'(68 1 2 3 4))
|
|
|
|
; test chains of consumers ending in a tail call
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-a))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(0 1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-a f1))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(68 4 1 2 3))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-a f1 f2 f3 f4))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(68 1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(call-with-values (lambda () (($mrvs-a f1 f2 f3))) foo)))
|
|
#t)
|
|
(equal? ($mrvs-q $mrvs-list) '(68 2 3 4 1))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-a f1 f2 f3))) foo))))
|
|
#t)
|
|
(equal? (($mrvs-q $mrvs-list)) '(68 2 3 4 1))
|
|
|
|
; test chains of consumers ending in a let-values
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-a))]) (cons* x r a))
|
|
'(0 (2 3 4) . 1))
|
|
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-a f1))]) (cons* x r a))
|
|
'(68 (1 2 3) . 4))
|
|
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-a f1 f2 f3 f4))]) (cons* x r a))
|
|
'(68 (2 3 4) . 1))
|
|
|
|
; test chains of consumers ending in a let-values-like call-with-values
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-a)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(0 (3 4) 2 . 1))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-a f1)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(68 (2 3) 1 . 4))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-a f1 f2 f3 f4)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(68 (3 4) 2 . 1))
|
|
|
|
(begin
|
|
(define-syntax $mrvs-qcons (lambda (x) #`'#,cons))
|
|
(define-syntax $mrvs-qvalues (lambda (x) #`'#,(lambda args (apply values args))))
|
|
(define $mrvs-f (lambda () (values 1 2)))
|
|
#t)
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (values 1 2)) $mrvs-qcons)
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(let ([f (lambda () (values 1 2))])
|
|
(call-with-values f $mrvs-qcons))
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(call-with-values $mrvs-f $mrvs-qcons)
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (call-with-values $mrvs-f $mrvs-qvalues)) $mrvs-qcons)
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(let ([f (lambda () (call-with-values (lambda () (values 1 2)) $mrvs-qcons))])
|
|
(f))
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(let ([f (lambda ()
|
|
(let ([f (lambda () (values 1 2))])
|
|
(call-with-values f $mrvs-qcons)))])
|
|
(f))
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(let ([f (lambda () (call-with-values $mrvs-f $mrvs-qcons))])
|
|
(f))
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(let ([f (lambda ()
|
|
(call-with-values
|
|
(lambda () (call-with-values $mrvs-f $mrvs-qvalues))
|
|
$mrvs-qcons))])
|
|
(f))
|
|
'(1 . 2))
|
|
|
|
(equal?
|
|
(letrec ((f (lambda (x) (values 7 8 9))))
|
|
(let ((h list))
|
|
(call-with-values
|
|
(lambda () (f 0))
|
|
h)))
|
|
'(7 8 9))
|
|
|
|
(equal?
|
|
(let-values ([(a . b) (values 1 2 3)]) (cons b a))
|
|
'((2 3) . 1))
|
|
|
|
(equal?
|
|
(let ([f (lambda (x) (values x (+ x 1)))])
|
|
(let-values ([(a b) (f 3)]) (cons b a)))
|
|
'(4 . 3))
|
|
|
|
; let-values inserts an "else" (effectively) clause---the following doesn't
|
|
(equal?
|
|
(let ([f (lambda (x) (values x (+ x 1)))])
|
|
(call-with-values
|
|
(lambda () (f 3))
|
|
(lambda (a b) (cons b a))))
|
|
'(4 . 3))
|
|
|
|
(equal?
|
|
(let ([f (lambda (x) (values x (+ x 1)))]) (begin (f 3) 7))
|
|
7)
|
|
|
|
(equal?
|
|
((lambda (a . b) (cons b a)) 7 8 9)
|
|
'((8 9) . 7))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda ()
|
|
(let ([f (lambda (x) (values x (+ x 1) (+ x 2)))]
|
|
[g (lambda () 7)])
|
|
(call-with-values g f)))
|
|
list*)
|
|
'(7 8 . 9))
|
|
|
|
(equal?
|
|
(let ([q (lambda () (let ([f (lambda (x) (values x (+ x 1) (+ x 2)))]
|
|
[g (lambda () 7)])
|
|
(call-with-values g f)))])
|
|
(call-with-values q (lambda (a b c) (list c b a))))
|
|
'(9 8 7))
|
|
|
|
(equal?
|
|
(let ([q (lambda () (let ([f (lambda (x y) (values x (+ x 1) (+ y 2)))]
|
|
[g (lambda () (values 7 8))])
|
|
(call-with-values g f)))])
|
|
(call-with-values q (lambda (a b c) (list c b a))))
|
|
'(10 8 7))
|
|
(error? ; unbound variable $mrvs-foo
|
|
(call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo))
|
|
(begin
|
|
(define $mrvs-foo 17)
|
|
#t)
|
|
(error? ; attempt to call nonprocedure 17
|
|
(call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo))
|
|
(begin
|
|
(define $mrvs-foo vector)
|
|
#t)
|
|
(equal?
|
|
(call-with-values (lambda () (set! $mrvs-foo list) (values 3 2 1)) $mrvs-foo)
|
|
'#(3 2 1))
|
|
(or (= (optimize-level) 3)
|
|
(eqv?
|
|
(let ([x 0] [f (lambda (x) (values 1 2))])
|
|
(guard (c [#t x])
|
|
(call-with-values
|
|
(begin (set! x (+ x 3)) f)
|
|
(begin (set! x (+ x 7)) 'oops))))
|
|
10))
|
|
(or (= (optimize-level) 3)
|
|
(eqv?
|
|
(let ([x 0] [f (lambda (x y z) (list z y x))])
|
|
(guard (c [#t x])
|
|
(#2%call-with-values
|
|
(begin (set! x (+ x 3)) 'oops)
|
|
(begin (set! x (+ x 7)) f))))
|
|
10))
|
|
|
|
; testing of chains that do not get washed away into direct calls with mvlet
|
|
(begin
|
|
(define-syntax $mrvs-c
|
|
(lambda (x)
|
|
(define help
|
|
(lambda (f* k)
|
|
(if (null? f*)
|
|
(k #'($mrvs-f0))
|
|
(with-syntax ([f1 (car f*)])
|
|
#`(let ([f1 (lambda (a b c d) (values d a b c))])
|
|
; using random to confuse cp0 until it gets smart enough to defeat this
|
|
(let ([f1 (if (eqv? (random 5) 10) #f f1)])
|
|
#,(help (cdr f*)
|
|
(lambda (body)
|
|
(k #`(call-with-values (lambda () #,body) f1))))))))))
|
|
(syntax-case x ()
|
|
[(_) #'($mrvs-f0)]
|
|
[(_ f1 f2 ...) (help #'(f1 f2 ...) values)])))
|
|
(define $mrvs-f0 (lambda () (values 1 2 3 4)))
|
|
(define $mrvs-list (lambda args args))
|
|
#t)
|
|
|
|
; test chains of consumers ending in a non-tail call
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-c)) $mrvs-list)
|
|
'(1 2 3 4))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-c f1)) $mrvs-list)
|
|
'(4 1 2 3))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () ($mrvs-c f1 f2 f3 f4)) $mrvs-list)
|
|
'(1 2 3 4))
|
|
|
|
; test chains of consumers ending in a tail call
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-c)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-c f1)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(4 1 2 3))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-c f1 f2 f3 f4)) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(call-with-values (lambda () ($mrvs-c f1 f2 f3)) foo)))
|
|
#t)
|
|
(equal? ($mrvs-q $mrvs-list) '(2 3 4 1))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(lambda ()
|
|
(call-with-values (lambda () ($mrvs-c f1 f2 f3)) foo))))
|
|
#t)
|
|
(equal? (($mrvs-q $mrvs-list)) '(2 3 4 1))
|
|
|
|
; test chains of consumers ending in a let-values
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-c)]) (cons r a))
|
|
'((2 3 4) . 1))
|
|
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-c f1)]) (cons r a))
|
|
'((1 2 3) . 4))
|
|
|
|
(equal?
|
|
(let-values ([(a . r) ($mrvs-c f1 f2 f3 f4)]) (cons r a))
|
|
'((2 3 4) . 1))
|
|
|
|
; test chains of consumers ending in a let-values-like call-with-values
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-c))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((3 4) 2 . 1))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-c f1))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((2 3) 1 . 4))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () ($mrvs-c f1 f2 f3 f4))
|
|
(lambda (a b . r) (cons* r b a)))
|
|
'((3 4) 2 . 1))
|
|
|
|
; test chains of consumers w/fi as free variables
|
|
(begin
|
|
(define-syntax $mrvs-c
|
|
(syntax-rules ()
|
|
[(_ f ...)
|
|
(let ([x 17])
|
|
(let ([f (lambda (y a b c d) (values x d a b c))] ...)
|
|
(let ([f (if (eqv? (random 5) 10) #f f)] ...)
|
|
(set! x (* x 4))
|
|
(lambda () ($mrvs-d f ...)))))]))
|
|
(define-syntax $mrvs-d
|
|
(syntax-rules ()
|
|
[(_) ($mrvs-f0)]
|
|
[(_ f1 f2 ...) (call-with-values (lambda () ($mrvs-d f2 ...)) f1)]))
|
|
(define $mrvs-f0 (lambda () (values 0 1 2 3 4)))
|
|
(define $mrvs-list (lambda args args))
|
|
#t)
|
|
|
|
; test chains of consumers ending in a non-tail call
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-c))) $mrvs-list)
|
|
'(0 1 2 3 4))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-c f1))) $mrvs-list)
|
|
'(68 4 1 2 3))
|
|
|
|
(equal?
|
|
(call-with-values (lambda () (($mrvs-c f1 f2 f3 f4))) $mrvs-list)
|
|
'(68 1 2 3 4))
|
|
|
|
; test chains of consumers ending in a tail call
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-c))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(0 1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-c f1))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(68 4 1 2 3))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-c f1 f2 f3 f4))) $mrvs-list)))
|
|
#t)
|
|
(equal? ($mrvs-q) '(68 1 2 3 4))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(call-with-values (lambda () (($mrvs-c f1 f2 f3))) foo)))
|
|
#t)
|
|
(equal? ($mrvs-q $mrvs-list) '(68 2 3 4 1))
|
|
|
|
(begin
|
|
(define $mrvs-q
|
|
(lambda (foo)
|
|
(lambda ()
|
|
(call-with-values (lambda () (($mrvs-c f1 f2 f3))) foo))))
|
|
#t)
|
|
(equal? (($mrvs-q $mrvs-list)) '(68 2 3 4 1))
|
|
|
|
; test chains of consumers ending in a let-values
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-c))]) (cons* x r a))
|
|
'(0 (2 3 4) . 1))
|
|
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-c f1))]) (cons* x r a))
|
|
'(68 (1 2 3) . 4))
|
|
|
|
(equal?
|
|
(let-values ([(x a . r) (($mrvs-c f1 f2 f3 f4))]) (cons* x r a))
|
|
'(68 (2 3 4) . 1))
|
|
|
|
; test chains of consumers ending in a let-values-like call-with-values
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-c)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(0 (3 4) 2 . 1))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-c f1)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(68 (2 3) 1 . 4))
|
|
|
|
(equal?
|
|
(call-with-values
|
|
(lambda () (($mrvs-c f1 f2 f3 f4)))
|
|
(lambda (x a b . r) (cons* x r b a)))
|
|
'(68 (3 4) 2 . 1))
|
|
|
|
; regression tests to make sure a bug in the compiler's handling of
|
|
; values in a single value context is properly handled in all cases
|
|
(begin
|
|
(module $mrvs-double-call (double-call)
|
|
(define split
|
|
(lambda (ls)
|
|
(if (null? ls)
|
|
(values #f '())
|
|
(values #t (cdr ls)))))
|
|
(define double-call
|
|
(lambda (x)
|
|
(let-values ([(x y) (split (split x))])
|
|
(list y x)))))
|
|
#t)
|
|
|
|
(error? ; returned two values to single value return context
|
|
(let ()
|
|
(import $mrvs-double-call)
|
|
(double-call '(a b))))
|
|
|
|
(error? ; returned two values to single value return context
|
|
(let ()
|
|
(import $mrvs-double-call)
|
|
(double-call '())))
|
|
|
|
(error? ; a is not a pair
|
|
(let ()
|
|
(import $mrvs-double-call)
|
|
(double-call 'a)))
|
|
|
|
; regression testing for handling mvset in tail context
|
|
(call-with-values
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(+ (random 1) 7))
|
|
list))
|
|
(lambda l (equal? l '((7)))))
|
|
|
|
; regression testing for handling mvset in predicate context
|
|
(if (call-with-values
|
|
(lambda ()
|
|
(call-with-values
|
|
(lambda ()
|
|
(+ (random 1) 7))
|
|
list))
|
|
(lambda l (equal? l '((7)))))
|
|
#t
|
|
#f)
|
|
|
|
; regression test for handling mvcall with inline form
|
|
(equal?
|
|
'(result x)
|
|
(let ([bx (box #f)])
|
|
(define-record-type thing
|
|
(fields pos)
|
|
(nongenerative #{thing hlg584lmg5htbdauw7dkid2sh-0}))
|
|
(set-box! bx (make-thing 'x))
|
|
(let ([posx (unbox bx)])
|
|
(cons 'result
|
|
(call-with-values
|
|
(lambda ()
|
|
(if (thing? posx)
|
|
;; compiled as inline load:
|
|
(thing-pos posx)
|
|
(do-something-else)))
|
|
list)))))
|
|
|
|
;; regression test to make sure the continuation is well formed when
|
|
;; an exception handler is call for a wrong number of values are
|
|
;; returned to a multi-value context
|
|
(begin
|
|
(define ($go-fail-to-get-two-values)
|
|
(call-with-values (lambda () ($get-one-value))
|
|
(lambda (a b) (list a b))))
|
|
(define ($get-one-value)
|
|
(call/cc ; copies return address off stack
|
|
(lambda (k)
|
|
(collect) ; do something non-trivial
|
|
k)))
|
|
(#%$continuation?
|
|
(call/cc
|
|
(lambda (esc)
|
|
(car
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(call/cc
|
|
(lambda (k) ; this continuation used to be broken, and
|
|
(collect) ; a GC was the simplest way of detecting it
|
|
(esc k))))
|
|
$go-fail-to-get-two-values))))))
|
|
|
|
)
|
|
|
|
(mat let-values
|
|
(error? (let-values))
|
|
(error? (let-values ((x))))
|
|
(error? (let-values ()))
|
|
(error? (let-values (((x) 3))))
|
|
(error? (let-values (((3) 4)) 5))
|
|
(error? (let-values (((3 4) (values 1 2))) 5))
|
|
(error? (let-values (((x . 3) (values 1 2 3))) x))
|
|
(error? (let-values ((() (values 1 2))) 7))
|
|
(error? (let-values (((x) (values 1 2))) x))
|
|
(error? (let-values (((x y z) (values 1 2))) x))
|
|
(error? (let-values (((x y z . w) (values 1 2))) x))
|
|
(error? (let-values ((() 1)) 7))
|
|
(error? (let-values (((x y) 1)) x))
|
|
(error? (let-values (((x y z) 1)) x))
|
|
(error? (let-values (((x y . w) 1)) x))
|
|
(error? (let-values (((x x . w) (values 1 2 3))) (list x w)))
|
|
(error? (let-values (((x y . w) (values 1 2 3)) [(x q) (values 4 5)]) (list x w q)))
|
|
(equal?
|
|
(let-values (((x) 3)) x)
|
|
3)
|
|
(equal?
|
|
(let-values (((x y) (values 3 4))) (list x y))
|
|
'(3 4))
|
|
(equal?
|
|
(let-values (((x . y) (values 3 4))) (list x y))
|
|
'(3 (4)))
|
|
(equal?
|
|
(let-values ((x (values 3 4))) x)
|
|
'(3 4))
|
|
(equal?
|
|
(let-values ((x 3)) x)
|
|
'(3))
|
|
(equal?
|
|
(let-values (((x . y) (values 1 2 3)) ((z) (values 4))) (list x y z))
|
|
'(1 (2 3) 4))
|
|
(equal?
|
|
(let ()
|
|
(define split
|
|
(lambda (ls)
|
|
(if (or (null? ls) (null? (cdr ls)))
|
|
(values ls '())
|
|
(let-values (((odds evens) (split (cddr ls))))
|
|
(values (cons (car ls) odds)
|
|
(cons (cadr ls) evens))))))
|
|
(call-with-values
|
|
(lambda () (split '(a b c d e f)))
|
|
vector))
|
|
'#((a c e) (b d f)))
|
|
(equal?
|
|
(let ()
|
|
(define f
|
|
(lambda (a b c)
|
|
(let-values (((d e) (let ((x values)) (x 1 2))))
|
|
(list a b c d e))))
|
|
(f 3 4 5))
|
|
'(3 4 5 1 2))
|
|
(equal?
|
|
(let ()
|
|
(define f1
|
|
(lambda (x) (apply values (vector->list x))))
|
|
(define f2
|
|
(lambda (a b)
|
|
(let-values ([(d) (f1 a)]
|
|
[(e . f) (f1 b)]
|
|
[(g h i) (f1 b)]
|
|
[j (f1 b)])
|
|
(list d e f g h i j))))
|
|
(f2 '#(a) '#(b c d)))
|
|
'(a b (c d) b c d (b c d)))
|
|
(eqv?
|
|
(letrec ((z 2)
|
|
(f (lambda () (values 1 z)))
|
|
(g (lambda (x y) (values x y z))))
|
|
(let-values ([(c d e) (let-values ([(z b) (f)]) (g z b))])
|
|
(+ c d e z)))
|
|
7)
|
|
(equal?
|
|
(let ([a 3])
|
|
(let-values ([(a b) (values (+ a 1) (+ a 2))]
|
|
[(c) (values (+ a 3))])
|
|
(list a b c)))
|
|
'(4 5 6))
|
|
; make sure pattern variables and ellipses on RHS don't screw us up
|
|
(eqv?
|
|
(let ()
|
|
(define-syntax q
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
|
|
(let-values ([(a) (q ...)]) a))
|
|
3)
|
|
(equal?
|
|
(syntax-case '(a b c) ()
|
|
[(x ...) (let-values ([(args) #'(x ...)]) args)])
|
|
'(a b c))
|
|
)
|
|
|
|
(mat let*-values
|
|
(error? (let*-values))
|
|
(error? (let*-values ((x))))
|
|
(error? (let*-values ()))
|
|
(error? (let*-values (((x) 3))))
|
|
(error? (let*-values (((3) 4)) 5))
|
|
(error? (let*-values (((3 4) (values 1 2))) 5))
|
|
(error? (let*-values (((x . 3) (values 1 2 3))) x))
|
|
(error? (let*-values ((() (values 1 2))) 7))
|
|
(error? (let*-values (((x) (values 1 2))) x))
|
|
(error? (let*-values (((x y z) (values 1 2))) x))
|
|
(error? (let*-values (((x y z . w) (values 1 2))) x))
|
|
(error? (let*-values ((() 1)) 7))
|
|
(error? (let*-values (((x y) 1)) x))
|
|
(error? (let*-values (((x y z) 1)) x))
|
|
(error? (let*-values (((x y . w) 1)) x))
|
|
(error? (let*-values (((x x . w) (values 1 2 3))) (list x w)))
|
|
(equal?
|
|
(let*-values (((x) 3)) x)
|
|
3)
|
|
(equal?
|
|
(let*-values (((x y) (values 3 4))) (list x y))
|
|
'(3 4))
|
|
(equal?
|
|
(let*-values (((x . y) (values 3 4))) (list x y))
|
|
'(3 (4)))
|
|
(equal?
|
|
(let*-values ((x (values 3 4))) x)
|
|
'(3 4))
|
|
(equal?
|
|
(let*-values ((x 3)) x)
|
|
'(3))
|
|
(equal?
|
|
(let*-values (((x . y) (values 1 2 3)) ((z) (values 4))) (list x y z))
|
|
'(1 (2 3) 4))
|
|
(equal?
|
|
(let ()
|
|
(define split
|
|
(lambda (ls)
|
|
(if (or (null? ls) (null? (cdr ls)))
|
|
(values ls '())
|
|
(let*-values (((odds evens) (split (cddr ls))))
|
|
(values (cons (car ls) odds)
|
|
(cons (cadr ls) evens))))))
|
|
(call-with-values
|
|
(lambda () (split '(a b c d e f)))
|
|
vector))
|
|
'#((a c e) (b d f)))
|
|
(equal?
|
|
(let ()
|
|
(define f
|
|
(lambda (a b c)
|
|
(let*-values (((d e) (let ((x values)) (x 1 2))))
|
|
(list a b c d e))))
|
|
(f 3 4 5))
|
|
'(3 4 5 1 2))
|
|
(equal?
|
|
(let ()
|
|
(define f1
|
|
(lambda (x) (apply values (vector->list x))))
|
|
(define f2
|
|
(lambda (a b)
|
|
(let*-values ([(d) (f1 a)]
|
|
[(e . f) (f1 b)]
|
|
[(g h i) (f1 b)]
|
|
[j (f1 b)])
|
|
(list d e f g h i j))))
|
|
(f2 '#(a) '#(b c d)))
|
|
'(a b (c d) b c d (b c d)))
|
|
(eqv?
|
|
(letrec ((z 2)
|
|
(f (lambda () (values 1 z)))
|
|
(g (lambda (x y) (values x y z))))
|
|
(let*-values ([(c d e) (let*-values ([(z b) (f)]) (g z b))])
|
|
(+ c d e z)))
|
|
7)
|
|
(equal?
|
|
(let ([a 3])
|
|
(let*-values ([(a b) (values (+ a 1) (+ a 2))]
|
|
[(c) (values (+ a 3))])
|
|
(list a b c)))
|
|
'(4 5 7))
|
|
; make sure pattern variables and ellipses on RHS don't screw us up
|
|
(eqv?
|
|
(let ()
|
|
(define-syntax q
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ dots) (free-identifier=? #'dots #'(... ...)) 3])))
|
|
(let*-values ([(a) (q ...)]) a))
|
|
3)
|
|
(equal?
|
|
(syntax-case '(a b c) ()
|
|
[(x ...) (let*-values ([(args) #'(x ...)]) args)])
|
|
'(a b c))
|
|
)
|