This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/3.ms

2311 lines
69 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; 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))
)