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/4.ms
2022-07-29 15:12:07 +02:00

3983 lines
140 KiB
Scheme

;;; 4.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.
;;; section 4-1:
(mat apply
(equal? (apply cons '(1 2)) '(1 . 2))
(equal? (apply list '(1 2 3 4 5)) '(1 2 3 4 5))
(equal? (apply (lambda (x . y) (list x y)) '(1 2 3 4 5)) '(1 (2 3 4 5)))
(equal? (apply list '(1 2 3)) '(1 2 3))
(equal? (apply list 1 '(2 3)) '(1 2 3))
(equal? (apply list 1 2 '(3)) '(1 2 3))
(equal? (apply list 1 2 3 '()) '(1 2 3))
(error? (apply))
(error? (apply list))
(error? (apply list 3))
(error? (apply list 3 4))
(error? (apply list 3 4 5 6 7 8 9))
(error? (apply list 3 '(4 . 5)))
(error? (apply list 3 4 5 6 7 8 9 '(10 . 11)))
(error? (apply + '#1=(1 2 . #1#)))
(equivalent-expansion?
(parameterize ([run-cp0 (lambda (cp0 x) (cp0 x))]
[#%$suppress-primitive-inlining #f]
[optimize-level 2])
(expand/optimize
`(let ()
(import scheme)
(apply + ',(make-list 1000 3)))))
3000)
)
;;; section 4-2:
(mat quote
(equal? '() (cdr '(a)))
(equal? '(a b c) (list 'a 'b 'c))
(equal? '#(a b c) (vector 'a 'b 'c))
(equal? 'a (string->symbol "a")))
(mat quasiquote ; adapted from The Scheme Programming Language
(equal? `(+ 2 3) '(+ 2 3))
(equal? `(+ 2 ,(* 3 4)) '(+ 2 12))
(equal? `(a b (,(+ 2 3) c) d) '(a b (5 c) d))
(equal? `(a b ,(reverse '(c d e)) f g) '(a b (e d c) f g))
(equal? `(+ ,@(cdr '(* 2 3))) '(+ 2 3))
(equal? `(a b ,@(reverse '(c d e)) f g) '(a b e d c f g))
(equal? '`,(cons 'a 'b) (list 'quasiquote (list 'unquote '(cons 'a 'b))))
(equal? `',(cons 'a 'b) ''(a . b))
(equal? `#(+ 2 3) '#(+ 2 3))
(equal? `#(+ 2 ,(* 3 4)) '#(+ 2 12))
(equal? `#(a b (,(+ 2 3) c) d) '#(a b (5 c) d))
(equal? `#(a b ,(reverse '(c d e)) f g) '#(a b (e d c) f g))
(equal? `#(+ ,@(cdr '(* 2 3))) '#(+ 2 3))
(equal? `#(a b ,@(reverse '(c d e)) f g) '#(a b e d c f g))
(equal? `#(10 5 ,@'(4 3)) '#(10 5 4 3))
(equal? (let ((x 1) (y 2))
`(foo (,x ,y)
`(bar ,@(baz ,y))))
'(foo (1 2) `(bar ,@(baz 2))))
(equal? `#&(10 5 ,@'(4 3)) '#&(10 5 4 3))
(equal? `#&,cons (box cons))
; test Bawden's extensions to quasiquote
(equal? `(a (unquote-splicing '(b) '(c)) d) '(a b c d))
(equal? `(a (unquote '(b) '(c)) d) '(a (b) (c) d))
(begin
(begin (define x '(m n)) (define m '(b c)) (define n '(d e)))
(equal?
(list (eval ``(a ,@,@x f) (interaction-environment))
(eval ``(a ,@,@x) (interaction-environment)))
'((a b c d e f) (a b c d e))))
; test to make sure we leave bare unquote alone in vectors
(equal? `#((+ 1 2) unquote)
'#((+ 1 2) unquote))
(equal? `#((+ 1 2) unquote (+ 3 4))
'#((+ 1 2) unquote (+ 3 4)))
(equal? `#((+ 1 2) unquote (list 3 4))
'#((+ 1 2) unquote (list 3 4)))
(equal? `#((+ 1 2) unquote (+ 2 3) (+ 3 4))
'#((+ 1 2) unquote (+ 2 3) (+ 3 4)))
(equal? `#(unquote)
'#(unquote))
(equal? `#(unquote (+ 3 4))
'#(unquote (+ 3 4)))
(equal? `#(unquote (list 3 4))
'#(unquote (list 3 4)))
(equal? `#(unquote (+ 2 3) (+ 3 4))
'#(unquote (+ 2 3) (+ 3 4)))
; new tests to exercise reimplementation
(let ([f (lambda () (import scheme) `(,'a . ,'b))])
(not (eq? (f) (f))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(,a . ,b)))
(if (= (optimize-level) 3)
'(#3%cons a b)
'(#2%cons a b)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(,a ,c . ,b)))
(if (= (optimize-level) 3)
'(#3%list* a c b)
'(#2%list* a c b)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a ,@b ,c d ,e f)))
(if (= (optimize-level) 3)
'(#3%cons 'a (#3%append b (#3%list* c 'd e '(f))))
'(#2%cons 'a (#2%append b (#2%list* c 'd e '(f))))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(,'a ,'c . ,'b)))
(if (= (optimize-level) 3)
'(#3%list* 'a 'c 'b)
'(#2%list* 'a 'c 'b)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b c)))
''(a b c))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b ,c)))
(if (= (optimize-level) 3)
'(#3%list 'a 'b c)
'(#2%list 'a 'b c)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(,'a ,@c ,'b)))
(if (= (optimize-level) 3)
'(#3%cons 'a (#3%append c (#3%list 'b)))
'(#2%cons 'a (#2%append c (#2%list 'b)))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a ,@'() c)))
(if (= (optimize-level) 3)
'(#3%cons 'a (#3%append '() '(c)))
'(#2%cons 'a (#2%append '() '(c)))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote) d)))
''(a b d))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote c1) d)))
(if (= (optimize-level) 3)
'(#3%list* 'a 'b c1 '(d))
'(#2%list* 'a 'b c1 '(d))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote c1 c2) d)))
(if (= (optimize-level) 3)
'(#3%list* 'a 'b c1 c2 '(d))
'(#2%list* 'a 'b c1 c2 '(d))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote c1) ,d)))
(if (= (optimize-level) 3)
'(#3%list 'a 'b c1 d)
'(#2%list 'a 'b c1 d)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote c1 c2) ,d)))
(if (= (optimize-level) 3)
'(#3%list 'a 'b c1 c2 d)
'(#2%list 'a 'b c1 c2 d)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote-splicing) d)))
''(a b d))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote-splicing c1) d)))
(if (= (optimize-level) 3)
'(#3%list* 'a 'b (#3%append c1 '(d)))
'(#2%list* 'a 'b (#2%append c1 '(d)))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a b (unquote-splicing c1 c2) d)))
(if (= (optimize-level) 3)
'(#3%list* 'a 'b (#3%append c1 c2 '(d)))
'(#2%list* 'a 'b (#2%append c1 c2 '(d)))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b c)))
''#(a b c))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(,c d)))
(if (= (optimize-level) 3)
'(#3%vector c 'd)
'(#2%vector c 'd)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b ,c)))
(if (= (optimize-level) 3)
'(#3%vector 'a 'b c)
'(#2%vector 'a 'b c)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b ,c d)))
(if (= (optimize-level) 3)
'(#3%vector 'a 'b c 'd)
'(#2%vector 'a 'b c 'd)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b ,@c d)))
(if (= (optimize-level) 3)
'(#3%list->vector (#3%list* 'a 'b (#3%append c '(d))))
'(#2%list->vector (#2%list* 'a 'b (#2%append c '(d))))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote) d)))
''#(a b d))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote c1) d)))
(if (= (optimize-level) 3)
'(#3%vector 'a 'b c1 'd)
'(#2%vector 'a 'b c1 'd)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote c1 c2) d)))
(if (= (optimize-level) 3)
'(#3%vector 'a 'b c1 c2 'd)
'(#2%vector 'a 'b c1 c2 'd)))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote-splicing) d)))
''#(a b d))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote-splicing c1) d)))
(if (= (optimize-level) 3)
'(#3%list->vector (#3%list* 'a 'b (#3%append c1 '(d))))
'(#2%list->vector (#2%list* 'a 'b (#2%append c1 '(d))))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`#(a b (unquote-splicing c1 c2) d)))
(if (= (optimize-level) 3)
'(#3%list->vector (#3%list* 'a 'b (#3%append c1 c2 '(d))))
'(#2%list->vector (#2%list* 'a 'b (#2%append c1 c2 '(d))))))
(equivalent-expansion?
(parameterize ([#%$suppress-primitive-inlining #f])
(expand '`(a `(b0 ,(b1 ,@b2 ,@b3)) (unquote c1 c2) ,d)))
(if (= (optimize-level) 3)
'(#3%list 'a
(#3%list 'quasiquote
(#3%list 'b0
(#3%list 'unquote (#3%cons 'b1 (#3%append b2 b3)))))
c1 c2 d)
'(#2%list 'a
(#2%list 'quasiquote
(#2%list 'b0
(#2%list 'unquote (#2%cons 'b1 (#2%append b2 b3)))))
c1 c2 d)))
)
;;; section 4-3:
(mat begin
(error? (or (begin) #t)) ;just see if (begin) is allowed
(begin (eq? 'a 'a))
(let ([x 'a]) (begin (set! x 'b) (eq? x 'b)))
(let ([x 'a])
(begin
(set! x 'b)
(set! x (cons x x))
(equal? x '(b . b))))
)
;;; section 4-4:
(mat if
(let ([x 'a])
(set! x 'b)
(and
(eq? (if (eq? x 'a) 'a 'b) 'b)
(eq? (if (eq? x 'b) 'a 'b) 'a)))
(let ([x 'a])
(if (eq? x 'a) (set! x 'b))
(if (eq? x 'a) (set! x 'c))
(eq? x 'b))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (not (not (f x))) e1 e2)))
'(if (f x) e1 e2))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #t)) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) e2 e1)))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #f #f)) e1 e2)))
'(begin (set! x y) (set! z y) (#2%zero? h) e2))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #t)) e1 e2)))
'(begin (set! x y) (set! z y) (#2%zero? h) e1))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) #t #f)) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) e1 e2)))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #f))) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e1) (begin (set! l y) e2))))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #t))) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e1))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #f))) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e2))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #t))) e1 e2)))
'(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e2) (begin (set! l y) e1))))
)
(mat when
(= (let ((x 12)) (when (= x 12) (set! x 11) (set! x 1)) x) 1)
(= (let ((x 12)) (when (= x 11) (set! x 11) (set! x 1)) x) 12)
)
(mat unless
(eq? (let ((y 'a)) (unless (eq? y 'b) (set! y 'c)) y) 'c)
(eq? (let ((y 'a)) (unless (eq? y 'a) (set! y 'c)) y) 'a)
)
(mat not
(not #f)
(not (not #t))
(let ((x 3)) (set! x 4) (not (= x 3)))
)
(mat and
(not (let ((x 'x)) (set! x #f) (and x #t #t)))
(eq? (let ((x 'x)) (and x (begin (set! x 'c) x) x)) 'c)
)
(mat or
(equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (cons x x) 3)) '(()))
(equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)) 3)) 3)
(not (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)))))
; make sure the following isn't incorrectly recognized as an or
(equal? (let ((x #f)) (if x x (cons x x))) '(#f . #f))
)
(mat cond
(error? ; invalid syntax
(cond))
(let ((a 'a))
(and (begin (set! a 3)
(cond ((= a 4) #f) ((= a 3) #t) (else #f)))
(begin (set! a 4)
(cond ((= a 4) #t) ((= a 3) #f) (else #f)))
(begin (set! a 2)
(cond ((= a 4) #f) ((= a 3) #f) (else #t)))
(begin (set! a 4)
(cond ((= a 4)) ((= a 3) #f) (else #f)))
(begin (set! a 3)
(cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
(eq? 'b (cond ((assq 'a '((a . b))) => cdr) (else #f)))
(equal? '(b c) (cond ((memq 'b '(a b c))) (else #f)))
; make sure cond requires procedure on RHS of =>
(error?
(let () ; aziz's strange example
(define-syntax x
(syntax-rules ()
((_ t) (lambda (t) t))))
((cond (#t => x)) 18)))
)
(mat exclusive-cond
(error? ; invalid syntax
(exclusive-cond [a . b]))
(error? ; invalid syntax
(exclusive-cond))
(let ((a 'a))
(and (begin (set! a 3)
(exclusive-cond ((= a 4) #f) ((= a 3) #t) (else #f)))
(begin (set! a 4)
(exclusive-cond ((= a 4) #t) ((= a 3) #f) (else #f)))
(begin (set! a 2)
(exclusive-cond ((= a 4) #f) ((= a 3) #f) (else #t)))
(begin (set! a 4)
(exclusive-cond ((= a 4) => (lambda (x) x)) ((= a 3) #f) (else #f)))
(begin (set! a 3)
(exclusive-cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
(eq? 'b (exclusive-cond ((assq 'a '((a . b))) => cdr) (else #f)))
(equal? '(b c) (exclusive-cond ((memq 'b '(a b c)) => (lambda (x) x)) (else #f)))
; make sure exclusive-cond requires procedure on RHS of =>
(error?
(let () ; aziz's strange example
(define-syntax x
(syntax-rules ()
((_ t) (lambda (t) t))))
((exclusive-cond (#t => x)) 18)))
; verify that exclusive cond actually reorders with profile information available
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(pretty-print
'(let ()
(define count1 0)
(define count2 0)
(define count3 0)
(define count4 0)
(define count5 0)
(define foo
(lambda (n)
(exclusive-cond
[(begin (set! count1 (+ count1 1)) (< n 5))
(set! count3 (+ count3 1))]
[(begin (set! count2 (+ count2 1)) (> n 5))
(set! count4 (+ count4 1))]
[else (set! count5 (+ count5 1))])))
(do ([i 10 (fx- i 1)])
((fx= i 0))
(foo 10))
(foo 3)
(pretty-print (list count1 count2 count3 count4 count5)))))
'replace)
(profile-clear-database)
#t)
(equal?
(with-output-to-string
(lambda ()
; make sure no collection occurs before profile data is dumped
(parameterize ([compile-profile #t] [collect-request-handler void])
(load "testfile.ss" compile)
(profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump))))
; make sure collections are restarted
(collect)))
"(11 10 1 10 0)\n")
(begin
(profile-load-data "testfile.pd")
#t)
(equal?
(with-output-to-string
(lambda ()
(load "testfile.ss" compile)))
"(1 11 1 10 0)\n")
(begin
(profile-clear-database)
#t)
(begin
(profile-load-data "testfile.pd" "testfile.pd")
#t)
(equal?
(with-output-to-string
(lambda ()
(load "testfile.ss" compile)))
"(1 11 1 10 0)\n")
(begin
(profile-clear-database)
#t)
)
(mat case
(error? ; invalid syntax
(case 3 [a . b]))
(eq? (case 'a [a 'yes] [b 'no]) 'yes)
(let ((a 'a))
(and
(begin (set! a 'a)
(case a (a #t) ((b c) #f))
(case a (a #t) ((b c) #f) (else #f)))
(begin (set! a 'b)
(case a (a #f) ((b c) #t))
(case a (a #f) ((b c) #t) (else #f)))
(begin (set! a 'c)
(case a (a #f) ((b c) #t))
(case a (a #f) ((b c) #t) (else #f)))
(begin (set! a 'd)
(case a (a #f) ((b c) #f) (else #t)))))
(let ([f (lambda (x)
(case x
(#\a 'case1)
(1/2 'case2)
(999999999999999 'case3)
(3.4 'case4)
(else 'oops)))])
(and (eq? (f (string-ref "abc" 0)) 'case1)
(eq? (f (exact 0.5)) 'case2)
(eq? (f (- 1000000000000000 1)) 'case3)
(eq? (f (+ 3.0 4/10)) 'case4)
(eq? (f 'b) 'oops)))
(case '() [() #f] [else #t])
(case '() [(()) #t] [else #f])
(case "meow" ["meow" #t] [else #f])
(case '(1 2 3) [((1 2 3) (3 2 1)) #t] [else #f])
(case 'a [1 6] ["meow" #f] [(a b c) #t])
(case #\: [1 6] ["meow" #f] [(a b c) #f] [(#\; #\9 #\: #\4) #t])
(case (/ 12.0 3.0) [(4 5 6) #f] [("bla") #f] [(a b c) #f] [(1 5.8 4.9 4.0) #t] [else #f])
(begin
(with-output-to-file "testfile.ss"
(lambda ()
(pretty-print
'(define foo
(lambda (x)
(case x
[("three" 4) 'B]
[("three" 5) 'A]
[else #f]))))
(pretty-print
'(begin
(do ([i 10 (fx- i 1)]) ((fx= i 0)) (write (foo 5)))
(write (foo "three")))))
'replace)
(profile-clear-database)
#t)
; verify no reordering w/no profile information
(let ([x (let* ([ip (open-file-input-port "testfile.ss")]
[sfd (make-source-file-descriptor "testfile.ss" ip #t)]
[ip (transcoded-port ip (native-transcoder))])
(let-values ([(x efp) (get-datum/annotations ip sfd 0)])
(close-port ip)
(parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))])
; redundant keys might or might not be pruned, so allow it both ways
(or (equivalent-expansion?
x
'(begin
(set! foo
(lambda (x)
(let ([t x])
(if (#2%member t '("three" 4))
'B
(if (#2%member t '("three" 5))
'A
#f)))))
(#2%void)))
(equivalent-expansion?
x
'(begin
(set! foo
(lambda (x)
(let ([t x])
(if (#2%member t '("three" 4))
'B
(if (#2%member t '(5))
'A
#f)))))
(#2%void)))))
(equal?
(with-output-to-string
(lambda ()
(parameterize ([compile-profile #t]) (load "testfile.ss" compile))))
"AAAAAAAAAAB")
(begin
(profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump)))
(profile-load-data "testfile.pd")
#t)
(equal?
(with-output-to-string
(lambda ()
(load "testfile.ss" compile)))
"AAAAAAAAAAB")
; verify reordering based on profile information
(equivalent-expansion?
(let* ([ip (open-file-input-port "testfile.ss")]
[sfd (make-source-file-descriptor "testfile.ss" ip #t)]
[ip (transcoded-port ip (native-transcoder))])
(let-values ([(x efp) (get-datum/annotations ip sfd 0)])
(close-port ip)
(parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))
'(begin
(set! foo
(lambda (x)
(let ([t x])
(if (#2%member t '(5))
'A
(if (#2%member t '("three" 4))
'B
#f)))))
(#2%void)))
(begin
(profile-clear-database)
#t)
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
(expand/optimize '(lambda (x) (case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
'(lambda (x)
(let ([t x])
(if (#2%member t '(a b 7))
'one
(if (#2%member t '(c 9))
'two
'three)))))
; ensure we don't miss syntax errors through case discarding unreachable clause bodies
(error? ; invalid syntax (if)
(lambda (x)
(case x
[(a) 'one]
[(b c) 'two]
[(a b c) (if)]
[else #f])))
; ensure expansion into cond doesn't cause => to "work" for case
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) => values])))
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) #f]
[(d e f) => values])))
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) #f]
[(a b c) => values])))
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) => values]
[else #f])))
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) #f]
[(d e f) => values]
[else #f])))
(error? ; invalid syntax =>
(lambda (x)
(case x
[(a b c) #f]
[(a b c) => values]
[else #f])))
(error? ; invalid syntax (case)
(case))
)
(mat r6rs:case
(error? ; invalid syntax
(let ()
(import (only (rnrs) case))
(case 'a [a 'yes] [b 'no])))
(error? ; invalid syntax
(let ()
(import (only (rnrs) case))
(case 'a [a 'yes] [b 'no])))
(let ((a 'a))
(import (only (rnrs) case))
(and
(begin (set! a 'a)
(case a ((a) #t) ((b c) #f))
(case a ((a) #t) ((b c) #f) (else #f)))
(begin (set! a 'b)
(case a ((a) #f) ((b c) #t))
(case a ((a) #f) ((b c) #t) (else #f)))
(begin (set! a 'c)
(case a ((a) #f) ((b c) #t))
(case a ((a) #f) ((b c) #t) (else #f)))
(begin (set! a 'd)
(case a ((a) #f) ((b c) #f) (else #t)))))
(let ([f (lambda (x)
(import (only (rnrs) case))
(case x
((#\a) 'case1)
((1/2) 'case2)
((999999999999999) 'case3)
((3.4) 'case4)
(else 'oops)))])
(and (eq? (f (string-ref "abc" 0)) 'case1)
(eq? (f (exact 0.5)) 'case2)
(eq? (f (- 1000000000000000 1)) 'case3)
(eq? (f (+ 3.0 4/10)) 'case4)
(eq? (f 'b) 'oops)))
(let ()
(import (only (rnrs) case))
(case '() [() #f] [else #t]))
(let ()
(import (only (rnrs) case))
(case '() [(()) #t] [else #f]))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
(expand/optimize '(lambda (x)
(import (only (rnrs) case))
(case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
'(lambda (x)
(let ([t x])
(if (#2%memv t '(a b 7))
'one
(if (#2%memv t '(c 9))
'two
'three)))))
; ensure we don't miss syntax errors through case discarding unreachable clause bodies
(error? ; invalid syntax (if)
(lambda (x)
(import (only (rnrs) case))
(case x
[(a) 'one]
[(b c) 'two]
[(a b c) (if)]
[else #f])))
; ensure expansion into cond doesn't cause => to "work" for case
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) => values])))
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) #f]
[(d e f) => values])))
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) #f]
[(a b c) => values])))
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) => values]
[else #f])))
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) #f]
[(d e f) => values]
[else #f])))
(error? ; invalid syntax =>
(lambda (x)
(import (only (rnrs) case))
(case x
[(a b c) #f]
[(a b c) => values]
[else #f])))
(error? ; invalid syntax (case)
(let ()
(import (only (rnrs) case))
(case)))
)
(mat record-case
(record-case '(a b c)
[a (b c) (and (eq? b 'b) (eq? c 'c))]
[b x #f]
[c x #f]
[else #f])
(record-case (list #\a #\b #\c)
[#\a (b c) (and (eq? b #\b) (eq? c #\c))]
[#\b x #f]
[#\c x #f])
(record-case (list (/ 3 4) 'b 'c)
[1/2 x #f]
[3/4 x (equal? x '(b c))]
[5/8 x #f]
[else #f])
(record-case '(d a b c)
[a x (equal? x '(b c))]
[b x #f]
[c x #f]
[else #t])
(record-case '(a b c d e)
[a (x1 x2 x3 . x4) (equal? (list x1 x2 x3 x4) '(b c d (e)))]
[else #f])
)
;;; section 4-5:
(mat named-let
(eqv? (let f ((x 5)) (if (zero? x) 1 (* x (f (1- x))))) 120)
(let f ((x 10000)) (if (zero? x) #t (f (1- x))))
(let f ([x 10] [y 0]) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))
(eqv? (let f ([x 10]) (if (= x 0) 1 (+ (f (- x 1)) 1))) 11)
(eqv? (let ([base 20])
(let f ([x 10])
(if (= x 0) base
(+ (f (- x 1)) 1))))
30)
; this looks almost like a named let, but isn't, and is treated as
; if the 4 were not present by some earlier verisons
(error? ((letrec ((x (lambda (x) x))) x) 3 4))
)
(define ($destroy ls x)
(when (pair? ls)
($destroy (cdr ls) x)
(set-cdr! ls x)))
(mat map
(eqv? (map car '()) '())
(equal? (map 1+ '(1 2 3 4 5 6)) '(2 3 4 5 6 7))
(equal? (map 1+ '()) '())
(equal? (map cons '(1 2 3) '(4 5 6)) '((1 . 4) (2 . 5) (3 . 6)))
(let ((x 3))
(equal? (apply + (map (lambda (y) (set! x (1+ x)) x) '(a b c d)))
22))
(equal? (map (lambda (x y z) (+ x (+ y z)))
'(1 2 3 4 5)
'(11 12 13 14 15)
'(21 22 23 24 25))
'(33 36 39 42 45))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '())
(map p '() x1)
(map p '() x1 x2)
(map p '() x1 x2 x3)
(map p '() x1 x2 x3 x4)
(map p '() x1 x2 x3 x4 x5)
(map p x1 '())
(map p x1 '() x2)
(map p x1 '() x2 x3)
(map p x1 '() x2 x3 x4)
(map p x1 '() x2 x3 x4 x5)
(map p x1 x2 '())
(map p x1 x2 '() x3)
(map p x1 x2 '() x3 x4)
(map p x1 x2 '() x3 x4 x5)
(map p x1 x2 x3 '())
(map p x1 x2 x3 '() x4)
(map p x1 x2 x3 '() x4 x5)
(map p x1 x2 x3 x4 '())
(map p x1 x2 x3 x4 '() x5)
(map p x1 x2 x3 x4 x5 '())))
(procedure? $map-f1))
(equal?
($map-f1 list '() '() '() '() '())
'(() () () () () () () () () () () () () () () () () ()
() () ()))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '(a))
(map p '(a) x1)
(map p '(a) x1 x2)
(map p '(a) x1 x2 x3)
(map p '(a) x1 x2 x3 x4)
(map p '(a) x1 x2 x3 x4 x5)
(map p x1 '(a))
(map p x1 '(a) x2)
(map p x1 '(a) x2 x3)
(map p x1 '(a) x2 x3 x4)
(map p x1 '(a) x2 x3 x4 x5)
(map p x1 x2 '(a))
(map p x1 x2 '(a) x3)
(map p x1 x2 '(a) x3 x4)
(map p x1 x2 '(a) x3 x4 x5)
(map p x1 x2 x3 '(a))
(map p x1 x2 x3 '(a) x4)
(map p x1 x2 x3 '(a) x4 x5)
(map p x1 x2 x3 x4 '(a))
(map p x1 x2 x3 x4 '(a) x5)
(map p x1 x2 x3 x4 x5 '(a))))
(procedure? $map-f1))
(equal?
($map-f1 list '(1) '(4) '(d) '(g) '(7))
'(((a))
((a 1))
((a 1 4))
((a 1 4 d))
((a 1 4 d g))
((a 1 4 d g 7))
((1 a))
((1 a 4))
((1 a 4 d))
((1 a 4 d g))
((1 a 4 d g 7))
((1 4 a))
((1 4 a d))
((1 4 a d g))
((1 4 a d g 7))
((1 4 d a))
((1 4 d a g))
((1 4 d a g 7))
((1 4 d g a))
((1 4 d g a 7))
((1 4 d g 7 a))))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '(a b))
(map p '(a b) x1)
(map p '(a b) x1 x2)
(map p '(a b) x1 x2 x3)
(map p '(a b) x1 x2 x3 x4)
(map p '(a b) x1 x2 x3 x4 x5)
(map p x1 '(a b))
(map p x1 '(a b) x2)
(map p x1 '(a b) x2 x3)
(map p x1 '(a b) x2 x3 x4)
(map p x1 '(a b) x2 x3 x4 x5)
(map p x1 x2 '(a b))
(map p x1 x2 '(a b) x3)
(map p x1 x2 '(a b) x3 x4)
(map p x1 x2 '(a b) x3 x4 x5)
(map p x1 x2 x3 '(a b))
(map p x1 x2 x3 '(a b) x4)
(map p x1 x2 x3 '(a b) x4 x5)
(map p x1 x2 x3 x4 '(a b))
(map p x1 x2 x3 x4 '(a b) x5)
(map p x1 x2 x3 x4 x5 '(a b))))
(procedure? $map-f1))
(equal?
($map-f1 list '(1 2) '(4 5) '(d e) '(g h) '(7 j))
'(((a) (b))
((a 1) (b 2))
((a 1 4) (b 2 5))
((a 1 4 d) (b 2 5 e))
((a 1 4 d g) (b 2 5 e h))
((a 1 4 d g 7) (b 2 5 e h j))
((1 a) (2 b))
((1 a 4) (2 b 5))
((1 a 4 d) (2 b 5 e))
((1 a 4 d g) (2 b 5 e h))
((1 a 4 d g 7) (2 b 5 e h j))
((1 4 a) (2 5 b))
((1 4 a d) (2 5 b e))
((1 4 a d g) (2 5 b e h))
((1 4 a d g 7) (2 5 b e h j))
((1 4 d a) (2 5 e b))
((1 4 d a g) (2 5 e b h))
((1 4 d a g 7) (2 5 e b h j))
((1 4 d g a) (2 5 e h b))
((1 4 d g a 7) (2 5 e h b j))
((1 4 d g 7 a) (2 5 e h j b))))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '(a b c))
(map p '(a b c) x1)
(map p '(a b c) x1 x2)
(map p '(a b c) x1 x2 x3)
(map p '(a b c) x1 x2 x3 x4)
(map p '(a b c) x1 x2 x3 x4 x5)
(map p x1 '(a b c))
(map p x1 '(a b c) x2)
(map p x1 '(a b c) x2 x3)
(map p x1 '(a b c) x2 x3 x4)
(map p x1 '(a b c) x2 x3 x4 x5)
(map p x1 x2 '(a b c))
(map p x1 x2 '(a b c) x3)
(map p x1 x2 '(a b c) x3 x4)
(map p x1 x2 '(a b c) x3 x4 x5)
(map p x1 x2 x3 '(a b c))
(map p x1 x2 x3 '(a b c) x4)
(map p x1 x2 x3 '(a b c) x4 x5)
(map p x1 x2 x3 x4 '(a b c))
(map p x1 x2 x3 x4 '(a b c) x5)
(map p x1 x2 x3 x4 x5 '(a b c))))
(procedure? $map-f1))
(equal?
($map-f1 list '(1 2 3) '(4 5 6) '(d e f) '(g h i) '(7 j 9))
'(((a) (b) (c))
((a 1) (b 2) (c 3))
((a 1 4) (b 2 5) (c 3 6))
((a 1 4 d) (b 2 5 e) (c 3 6 f))
((a 1 4 d g) (b 2 5 e h) (c 3 6 f i))
((a 1 4 d g 7) (b 2 5 e h j) (c 3 6 f i 9))
((1 a) (2 b) (3 c))
((1 a 4) (2 b 5) (3 c 6))
((1 a 4 d) (2 b 5 e) (3 c 6 f))
((1 a 4 d g) (2 b 5 e h) (3 c 6 f i))
((1 a 4 d g 7) (2 b 5 e h j) (3 c 6 f i 9))
((1 4 a) (2 5 b) (3 6 c))
((1 4 a d) (2 5 b e) (3 6 c f))
((1 4 a d g) (2 5 b e h) (3 6 c f i))
((1 4 a d g 7) (2 5 b e h j) (3 6 c f i 9))
((1 4 d a) (2 5 e b) (3 6 f c))
((1 4 d a g) (2 5 e b h) (3 6 f c i))
((1 4 d a g 7) (2 5 e b h j) (3 6 f c i 9))
((1 4 d g a) (2 5 e h b) (3 6 f i c))
((1 4 d g a 7) (2 5 e h b j) (3 6 f i c 9))
((1 4 d g 7 a) (2 5 e h j b) (3 6 f i 9 c))))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '(a b c d))
(map p '(a b c d) x1)
(map p '(a b c d) x1 x2)
(map p '(a b c d) x1 x2 x3)
(map p '(a b c d) x1 x2 x3 x4)
(map p '(a b c d) x1 x2 x3 x4 x5)
(map p x1 '(a b c d))
(map p x1 '(a b c d) x2)
(map p x1 '(a b c d) x2 x3)
(map p x1 '(a b c d) x2 x3 x4)
(map p x1 '(a b c d) x2 x3 x4 x5)
(map p x1 x2 '(a b c d))
(map p x1 x2 '(a b c d) x3)
(map p x1 x2 '(a b c d) x3 x4)
(map p x1 x2 '(a b c d) x3 x4 x5)
(map p x1 x2 x3 '(a b c d))
(map p x1 x2 x3 '(a b c d) x4)
(map p x1 x2 x3 '(a b c d) x4 x5)
(map p x1 x2 x3 x4 '(a b c d))
(map p x1 x2 x3 x4 '(a b c d) x5)
(map p x1 x2 x3 x4 x5 '(a b c d))))
(procedure? $map-f1))
(equal?
($map-f1 list '(1 2 3 4) '(f g h i) '(k l m n) '(p q r s) '(u v w x))
'(((a) (b) (c) (d)) ((a 1) (b 2) (c 3) (d 4))
((a 1 f) (b 2 g) (c 3 h) (d 4 i))
((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n))
((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s))
((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x))
((1 a) (2 b) (3 c) (4 d))
((1 a f) (2 b g) (3 c h) (4 d i))
((1 a f k) (2 b g l) (3 c h m) (4 d i n))
((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s))
((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x))
((1 f a) (2 g b) (3 h c) (4 i d))
((1 f a k) (2 g b l) (3 h c m) (4 i d n))
((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s))
((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x))
((1 f k a) (2 g l b) (3 h m c) (4 i n d))
((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s))
((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x))
((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d))
((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x))
((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d))))
(begin
(define ($map-f1 p x1 x2 x3 x4 x5)
(list
(map p '(a b c d e))
(map p '(a b c d e) x1)
(map p '(a b c d e) x1 x2)
(map p '(a b c d e) x1 x2 x3)
(map p '(a b c d e) x1 x2 x3 x4)
(map p '(a b c d e) x1 x2 x3 x4 x5)
(map p x1 '(a b c d e))
(map p x1 '(a b c d e) x2)
(map p x1 '(a b c d e) x2 x3)
(map p x1 '(a b c d e) x2 x3 x4)
(map p x1 '(a b c d e) x2 x3 x4 x5)
(map p x1 x2 '(a b c d e))
(map p x1 x2 '(a b c d e) x3)
(map p x1 x2 '(a b c d e) x3 x4)
(map p x1 x2 '(a b c d e) x3 x4 x5)
(map p x1 x2 x3 '(a b c d e))
(map p x1 x2 x3 '(a b c d e) x4)
(map p x1 x2 x3 '(a b c d e) x4 x5)
(map p x1 x2 x3 x4 '(a b c d e))
(map p x1 x2 x3 x4 '(a b c d e) x5)
(map p x1 x2 x3 x4 x5 '(a b c d e))))
(procedure? $map-f1))
(equal?
($map-f1 list '(1 2 3 4 5) '(f g h i j) '(k l m n o) '(p q r s t) '(u v w x y))
'(((a) (b) (c) (d) (e)) ((a 1) (b 2) (c 3) (d 4) (e 5))
((a 1 f) (b 2 g) (c 3 h) (d 4 i) (e 5 j))
((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n) (e 5 j o))
((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s) (e 5 j o t))
((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x) (e 5 j o t y))
((1 a) (2 b) (3 c) (4 d) (5 e))
((1 a f) (2 b g) (3 c h) (4 d i) (5 e j))
((1 a f k) (2 b g l) (3 c h m) (4 d i n) (5 e j o))
((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s) (5 e j o t))
((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x) (5 e j o t y))
((1 f a) (2 g b) (3 h c) (4 i d) (5 j e))
((1 f a k) (2 g b l) (3 h c m) (4 i d n) (5 j e o))
((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s) (5 j e o t))
((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x) (5 j e o t y))
((1 f k a) (2 g l b) (3 h m c) (4 i n d) (5 j o e))
((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s) (5 j o e t))
((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x) (5 j o e t y))
((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d) (5 j o t e))
((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x) (5 j o t e y))
((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e))))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (map x)))
(error? ; nonprocedure
(map 3 '()))
(error? ; nonprocedure
(map 3 '() '()))
(error? ; nonprocedure
(map 3 '(a b c)))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval '(#2%map 3 '(a b c)))))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval
'(let ()
(define (f p b)
(unbox b)
(#2%map p (if (box? b) '() '(1 2 3)))
(list p (procedure? p)))
(f 7 (box 0))))))
(error? ; improper list
(map pretty-print 'a))
(error? ; improper list
(map pretty-print '(a . b)))
(error? ; cyclic list
(map pretty-print '#1=(a . #1#)))
(error? ; length mismatch
(map list '(a b) '(p q r)))
(error? ; length mismatch
(map list '(1 2) '(a b) '(p q r)))
(error? ; improper list
(map list 'a '(a b)))
(error? ; improper list
(map list '(a b) 'a))
(error? ; improper list
(map list '(a . b) '(a b)))
(error? ; improper list
(map list '(a b) '(a . b)))
(error? ; cyclic list
(map list '#1# '(a b c)))
(error? ; cyclic list
(map list '(a b c) '#1#))
(error? ; improper list
(map list 'a '(a b) '(1 2)))
(error? ; improper list
(map list '(a b) 'a '(1 2)))
(error? ; improper list
(map list '(a b) '(1 2) 'a))
(error? ; improper list
(map list '(a . b) '(a b) '(1 2)))
(error? ; improper list
(map list '(a b) '(a . b) '(1 2)))
(error? ; improper list
(map list '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(map list '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(map list '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(map list '(a b c) '(1 2 3) '#1#))
(equal?
(let ((l (list 1 2 3 4)))
(map (lambda (x) ($destroy l 1) (* x x)) l))
'(1 4 9 16))
(equal?
(let ((l (list 1 2 3 4)))
(map (lambda (x y) ($destroy l y) (cons x y)) l '(a b c d)))
'((1 . a) (2 . b) (3 . c) (4 . d)))
(equal?
(let ((l (list 1 2 3 4)))
(map (lambda (x y) ($destroy l '()) (cons x y)) l '(a b c d)))
'((1 . a) (2 . b) (3 . c) (4 . d)))
(equal?
(let ((l (list 1 2 3 4)))
(map (lambda (x y) ($destroy l y) (cons x y)) '(a b c d) l))
'((a . 1) (b . 2) (c . 3) (d . 4)))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(map (lambda (x y z) ($destroy l '()) (list z x y))
l
'(a b c d e f g)
'(p q r s t u v)))
'((p 1 a) (q 2 b) (r 3 c) (s 4 d) (t 5 e) (u 6 f) (v 7 g)))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(map (lambda (x y z) ($destroy l '()) (list z x y))
'(a b c d e f g)
l
'(p q r s t u v)))
'((p a 1) (q b 2) (r c 3) (s d 4) (t e 5) (u f 6) (v g 7)))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(map (lambda (x y z) ($destroy l '()) (list z x y))
'(a b c d e f g)
'(p q r s t u v)
l))
'((1 a p) (2 b q) (3 c r) (4 d s) (5 e t) (6 f u) (7 g v)))
(let ([orig-ls #f] [orig-cars #f] [orig-cdrs #f] [next #f])
(define (copy-spine ls)
(if (null? ls)
'()
(cons ls (copy-spine (cdr ls)))))
(let ([n 100])
(let ([ls (map (lambda (x) (cons (call/cc values) x)) (iota n))])
(if orig-ls
(begin
(unless (andmap eq? orig-ls orig-cars)
(errorf #f "original map cars mutated"))
(unless (andmap eq? (copy-spine orig-ls) orig-cdrs)
(errorf #f "original map cdrs mutated")))
(begin
(set! orig-ls ls)
(set! orig-cars (list-copy ls))
(set! orig-cdrs (copy-spine ls))
(set! next 0)))
(let ([m next])
(unless (= m n)
(set! next (fx+ next 1))
(let ([p (list-ref orig-ls m)])
(unless (eqv? (cdr p) m)
(errorf #f "unexpected cdr value (~s instead of ~s)" (cdr p) m))
((car p) n)))))
(eqv? next n)))
(equal?
(let ([x 3])
(let ([y (map (begin (set! x 14) cons) '())])
(list x y)))
'(14 ()))
(equal?
(let ([x 3])
(let ([y (map (begin (set! x 14) list) '() '() '())])
(list x y)))
'(14 ()))
;; cp0 optimizations for map
;; mapping over empty list(s) always returns '()
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
;; if map is called only for effects, remove the expression only if the procedure
;; has the correct arity and can't raise an error
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map list '(5 4 3 2 1 0)) 7)))
7)
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map box? '(5 4 3 2 1 0)) 7)))
7)
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map unbox '(5 4 3 2 1 0)) 7)))
7))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map cons '(5 4 3 2 1 0)) 7)))
7))
;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
;; avoid creating each list and doing the actual map
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
(list 1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(#2%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
(list 1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(#3%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
'(1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(#2%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
'(1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(#3%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
'(1 2 3)
'(4 5 6)
'((7) (8) (9)))))
'(#2%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z) (apply + x y z))
'(1 2 3)
'(4 5 6)
'((7) (8) (9)))))
'(#3%list 12 15 18))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z)
(string->symbol
(apply
string-append
(map symbol->string (list x y z)))))
(list 'a 't 'x)
(list 'b 'u 'y)
(list 'c 'v 'z))))
'(#2%list
(#2%string->symbol (#2%string-append "a" "b" "c"))
(#2%string->symbol (#2%string-append "t" "u" "v"))
(#2%string->symbol (#2%string-append "x" "y" "z"))))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(map (lambda (x y z)
(string->symbol
(apply
string-append
(map symbol->string (list x y z)))))
(list 'a 't 'x)
(list 'b 'u 'y)
(list 'c 'v 'z))))
'(#3%list
(#3%string->symbol (#3%string-append "a" "b" "c"))
(#3%string->symbol (#3%string-append "t" "u" "v"))
(#3%string->symbol (#3%string-append "x" "y" "z"))))
(equal?
(with-output-to-string
(lambda ()
(pretty-print (map (begin (write 'ab) (lambda (x y) (cons x y)))
(begin (write 'a) (list (begin (write 'b) 'c)))
(begin (write 'a) (list (begin (write 'b) 'd)))))))
"ababab((c . d))\n")
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(pretty-print (map (lambda (x y) (cons x y))
(list (begin (write 'a) 'c) (begin (write 'b) 'd))
(list (begin (write 'x) 'e) (begin (write 'y) 'f))))))
; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby
'("abxy((c . e) (d . f))\n"
"abyx((c . e) (d . f))\n"
"baxy((c . e) (d . f))\n"
"bayx((c . e) (d . f))\n"
"xyab((c . e) (d . f))\n"
"yxab((c . e) (d . f))\n"
"xyba((c . e) (d . f))\n"
"yxba((c . e) (d . f))\n"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(pretty-print (map (lambda (x y z) (cons* x y z))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
'("abcdef((g h . i) (j k . l))\n"
"abefcd((g h . i) (j k . l))\n"
"cdabef((g h . i) (j k . l))\n"
"cdefab((g h . i) (j k . l))\n"
"efabcd((g h . i) (j k . l))\n"
"efcdab((g h . i) (j k . l))\n"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(pretty-print (map (lambda (x y z) (cons* x y z))
(begin (write 'ab) '(g j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
'("abcdef((g h . i) (j k . l))\n"
"abefcd((g h . i) (j k . l))\n"
"cdabef((g h . i) (j k . l))\n"
"cdefab((g h . i) (j k . l))\n"
"efabcd((g h . i) (j k . l))\n"
"efcdab((g h . i) (j k . l))\n"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(pretty-print (map (lambda (x y z) (cons* x y z))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'cd) '(h k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
'("abcdef((g h . i) (j k . l))\n"
"abefcd((g h . i) (j k . l))\n"
"cdabef((g h . i) (j k . l))\n"
"cdefab((g h . i) (j k . l))\n"
"efabcd((g h . i) (j k . l))\n"
"efcdab((g h . i) (j k . l))\n"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(pretty-print (map (lambda (x y z) (cons* x y z))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'ef) '(i l))))))
'("abcdef((g h . i) (j k . l))\n"
"abefcd((g h . i) (j k . l))\n"
"cdabef((g h . i) (j k . l))\n"
"cdefab((g h . i) (j k . l))\n"
"efabcd((g h . i) (j k . l))\n"
"efcdab((g h . i) (j k . l))\n"))
)
(mat fold-left
; next several are from r6rs
(eqv? (fold-left + 0 '(1 2 3 4 5)) 15)
(equal?
(fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
'(5 4 3 2 1))
(eqv?
(fold-left
(lambda (count x) (if (odd? x) (+ count 1) count))
0
'(3 1 4 1 5 9 2 6 5 3))
7)
(eqv?
(fold-left
(lambda (max-len s) (max max-len (string-length s)))
0
'("longest" "long" "longer"))
7)
(equal?
(fold-left cons '(q) '(a b c))
'((((q) . a) . b) . c))
(eqv?
(fold-left + 0 '(1 2 3) '(4 5 6))
21)
(procedure? (lambda (x) (fold-left x)))
(procedure? (lambda (x) (fold-left x y)))
(error? ; nonprocedure
(fold-left 3 0 '()))
(error? ; nonprocedure
(fold-left 3 0 '() '()))
(error? ; nonprocedure
(fold-left 3 0 '(a b c)))
(error? ; improper list
(fold-left cons 0 'a))
(error? ; improper list
(fold-left cons 0 '(a . b)))
(error? ; cyclic list
(fold-left cons 0 '#1=(a . #1#)))
(error? ; length mismatch
(fold-left list 0 '(a b) '(p q r)))
(error? ; length mismatch
(fold-left list 0 '(1 2) '(a b) '(p q r)))
(error? ; improper list
(fold-left list 0 'a '(a b)))
(error? ; improper list
(fold-left list 0 '(a b) 'a))
(error? ; improper list
(fold-left list 0 '(a . b) '(a b)))
(error? ; improper list
(fold-left list 0 '(a b) '(a . b)))
(error? ; cyclic list
(fold-left list 0 '#1# '(a b c)))
(error? ; cyclic list
(fold-left list 0 '(a b c) '#1#))
(error? ; improper list
(fold-left list 0 'a '(a b) '(1 2)))
(error? ; improper list
(fold-left list 0 '(a b) 'a '(1 2)))
(error? ; improper list
(fold-left list 0 '(a b) '(1 2) 'a))
(error? ; improper list
(fold-left list 0 '(a . b) '(a b) '(1 2)))
(error? ; improper list
(fold-left list 0 '(a b) '(a . b) '(1 2)))
(error? ; improper list
(fold-left list 0 '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(fold-left list 0 '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(fold-left list 0 '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(fold-left list 0 '(a b c) '(1 2 3) '#1#))
(error? ; list altered
(let ((l (list 1 2 3 4)))
(fold-left (lambda (a x) ($destroy l 1) (+ x a)) 0 l)))
(error? ; list altered
(let ((l (list 1 2 3 4)))
(fold-left (lambda (a x y) ($destroy l 'q) (list* a x y)) 0 l '(a b c d))))
(error? ; list altered
(let ((l (list 1 2 3 4)))
(fold-left (lambda (a x y) ($destroy l 'q) (cons x y)) 0 l '(a b c d))))
(error? ; list altered
(let ((l (list 1 2 3 4)))
(fold-left (lambda (a x y) ($destroy l 'q) (cons x y)) 0 '(a b c d) l)))
(error? ; list altered
(let ((l (list 1 2 3 4 5 6 7)))
(fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
0
l
'(a b c d e f g)
'(p q r s t u v))))
(error? ; list altered
(let ((l (list 1 2 3 4 5 6 7)))
(fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
0
'(a b c d e f g)
l
'(p q r s t u v))))
(error? ; list altered
(let ((l (list 1 2 3 4 5 6 7)))
(fold-left (lambda (a x y z) ($destroy l 'q) (list z x y))
0
'(a b c d e f g)
'(p q r s t u v)
l)))
)
(mat fold-right
; next several are from r6rs
(eqv? (fold-right + 0 '(1 2 3 4 5)) 15)
(equal?
(fold-right cons '() '(1 2 3 4 5))
'(1 2 3 4 5))
(equal?
(fold-right
(lambda (x l) (if (odd? x) (cons x l) l))
'()
'(3 1 4 1 5 9 2 6 5))
'(3 1 1 5 9 5))
(equal?
(fold-right cons '(q) '(a b c))
'(a b c q))
(eqv? (fold-right + 0 '(1 2 3) '(4 5 6)) 21)
(eqv? (fold-right list 75 '()) 75)
(equal?
(let ([x 3])
(let ([y (fold-right (begin (set! x 14) cons) 75 '())])
(list x y)))
'(14 75))
(equal?
(let ([x 3])
(let ([y (fold-right (begin (set! x 14) list) 75 '() '() '())])
(list x y)))
'(14 75))
(equal?
(fold-right
(lambda (a b) (cons (1+ a) b))
'q
'(1 2 3 4 5 6))
'(2 3 4 5 6 7 . q))
(equal?
(fold-right list* 'q '(1 2 3 4) '(5 6 7 8) '(9 10 11 12))
'(1 5 9 2 6 10 3 7 11 4 8 12 . q))
(equal?
(let ((x 3))
(fold-right (lambda (y a) (set! x (1+ x)) (+ x a)) '5 '(a b c d)))
27)
(equal?
(fold-right (lambda (x y z a) (cons (+ x (+ y z)) a)) 'q
'(1 2 3 4 5) '(11 12 13 14 15) '(21 22 23 24 25))
'(33 36 39 42 45 . q))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (fold-right x)))
(procedure? (lambda (x) (fold-right x y)))
(error? ; nonprocedure
(fold-right 3 0 '()))
(error? ; nonprocedure
(fold-right 3 0 '() '()))
(error? ; nonprocedure
(fold-right 3 0 '(a b c)))
(error? ; improper list
(fold-right list 0 'a))
(error? ; improper list
(fold-right list 0 '(a . b)))
(error? ; cyclic list
(fold-right list 0 '#1=(a . #1#)))
(error? ; length mismatch
(fold-right list 0 '(a b) '(p q r)))
(error? ; length mismatch
(fold-right list 0 '(1 2) '(a b) '(p q r)))
(error? ; improper list
(fold-right list 0 'a '(a b)))
(error? ; improper list
(fold-right list 0 '(a b) 'a))
(error? ; improper list
(fold-right list 0 '(a . b) '(a b)))
(error? ; improper list
(fold-right list 0 '(a b) '(a . b)))
(error? ; cyclic list
(fold-right list 0 '#1# '(a b c)))
(error? ; cyclic list
(fold-right list 0 '(a b c) '#1#))
(error? ; improper list
(fold-right list 0 'a '(a b) '(1 2)))
(error? ; improper list
(fold-right list 0 '(a b) 'a '(1 2)))
(error? ; improper list
(fold-right list 0 '(a b) '(1 2) 'a))
(error? ; improper list
(fold-right list 0 '(a . b) '(a b) '(1 2)))
(error? ; improper list
(fold-right list 0 '(a b) '(a . b) '(1 2)))
(error? ; improper list
(fold-right list 0 '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(fold-right list 0 '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(fold-right list 0 '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(fold-right list 0 '(a b c) '(1 2 3) '#1#))
(equal?
(let ((l (list 1 2 3 4)))
(fold-right (lambda (x a) ($destroy l 1) (cons (* x x) a)) 'q l))
'(1 4 9 16 . q))
(equal?
(let ((l (list 1 2 3 4)))
(fold-right
(lambda (x y a) ($destroy l y) (cons (cons x y) a))
'q
l
'(a b c d)))
'((1 . a) (2 . b) (3 . c) (4 . d) . q))
(equal?
(let ((l (list 1 2 3 4)))
(fold-right
(lambda (x y a) ($destroy l '()) (cons (cons x y) a))
'q
l
'(a b c d)))
'((1 . a) (2 . b) (3 . c) (4 . d) . q))
(equal?
(let ((l (list 1 2 3 4)))
(fold-right
(lambda (x y a) ($destroy l y) (cons (cons x y) a))
'q
'(a b c d)
l))
'((a . 1) (b . 2) (c . 3) (d . 4) . q))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
'q
l
'(a b c d e f g)
'(p q r s t u v)))
'((p 1 a) (q 2 b) (r 3 c) (s 4 d) (t 5 e) (u 6 f) (v 7 g) . q))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
'q
'(a b c d e f g)
l
'(p q r s t u v)))
'((p a 1) (q b 2) (r c 3) (s d 4) (t e 5) (u f 6) (v g 7) . q))
(equal?
(let ((l (list 1 2 3 4 5 6 7)))
(fold-right (lambda (x y z a) ($destroy l '()) (cons (list z x y) a))
'q
'(a b c d e f g)
'(p q r s t u v)
l))
'((1 a p) (2 b q) (3 c r) (4 d s) (5 e t) (6 f u) (7 g v) . q))
)
(mat for-each
(let ((x 0))
(for-each (lambda (y) (set! x (1- x))) '(1 2 3 4 5 6 7))
(= x -7))
(let ((x 0))
(for-each (lambda (y) (set! x (1- x))) '())
(= x 0))
(let ((x '()))
(for-each (lambda (y) (set! x (cons y x))) '(a b c d))
(equal? x '(d c b a)))
(let ((x 0))
(for-each
(lambda (y z) (set! x (+ x (- y z))))
'(4 5 6)
'(3 2 1))
(= x 9))
(let ((x 0))
(for-each
(lambda (y z w) (set! x (+ x (+ y (- z w)))))
'(-1 -2 -3)
'(4 5 6)
'(3 2 1))
(= x 3))
(let ((x 0))
(for-each
(lambda (y z w) (set! x (+ x (+ y (- z w)))))
'()
'()
'())
(= x 0))
; check for proper tail recursion
(equal?
(list
(let ([s (statistics)])
(let ([k 100000] [ls '(a b c)])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (for-each foo ls)))
(define (foo x)
(set! m (+ m 1))
(when (eq? x (car (last-pair ls)))
(set! n (- n 1))
(f)
17)) ; blow tail recursion here
(f)
(list (> (sstats-bytes (sstats-difference (statistics) s))
10000)
(eqv? n 0)
(eqv? m (* k (length ls)))))))
(let ([s (statistics)])
(let ([k 100000] [ls '(a b c)])
(let ([n k] [m 0])
(define (f) (unless (fx= n 0) (for-each foo ls)))
(define (foo x)
(set! m (+ m 1))
(when (eq? x (car (last-pair ls)))
(set! n (- n 1))
(f)))
(f)
(list (<= 0
(sstats-bytes (sstats-difference (statistics) s))
1000)
(eqv? n 0)
(eqv? m (* k (length ls))))))))
'((#t #t #t) (#t #t #t)))
(eqv?
(for-each (lambda (x y) (+ x y)) '(1 2 3) '(4 5 6))
9)
(let-values ([() (for-each
(lambda (x y) (if (eqv? x 3) (values) (+ x y)))
'(1 2 3)
'(4 5 6))])
#t)
(equal?
(let-values ([(a b) (for-each
(lambda (x y) (if (eqv? x 3) (values x y) (+ x y)))
'(1 2 3)
'(4 5 6))])
(list a b))
'(3 6))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (for-each x)))
(error? ; nonprocedure
(for-each 3 '()))
(error? ; nonprocedure
(for-each 3 '() '()))
(error? ; nonprocedure
(for-each 3 '(a b c)))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval '(#2%for-each 3 '(a b c)))))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval
'(let ()
(define (f p b)
(unbox b)
(#2%for-each p (if (box? b) '() '(1 2 3)))
(list p (procedure? p)))
(f 7 (box 0))))))
(error? ; improper list
(for-each pretty-print 'a))
(error? ; improper list
(for-each pretty-print '(a . b)))
(error? ; cyclic list
(for-each pretty-print '#1=(a . #1#)))
(error? ; length mismatch
(for-each (lambda (x y) (write (list x y))) '(a b) '(p q r)))
(error? ; length mismatch
(for-each (lambda (x y z) (write (list x y z))) '(1 2) '(a b) '(p q r)))
(error? ; improper list
(for-each values 'a '(a b)))
(error? ; improper list
(for-each values '(a b) 'a))
(error? ; improper list
(for-each values '(a . b) '(a b)))
(error? ; improper list
(for-each values '(a b) '(a . b)))
(error? ; cyclic list
(for-each values '#1# '(a b c)))
(error? ; cyclic list
(for-each values '(a b c) '#1#))
(error? ; improper list
(for-each values 'a '(a b) '(1 2)))
(error? ; improper list
(for-each values '(a b) 'a '(1 2)))
(error? ; improper list
(for-each values '(a b) '(1 2) 'a))
(error? ; improper list
(for-each values '(a . b) '(a b) '(1 2)))
(error? ; improper list
(for-each values '(a b) '(a . b) '(1 2)))
(error? ; improper list
(for-each values '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(for-each values '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(for-each values '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(for-each values '(a b c) '(1 2 3) '#1#))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x) (set-cdr! (cdr l) 1)) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x) (set-cdr! (cddr l) 1)) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y) (set-cdr! (cdr l) y)) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y) (set-cdr! (cddr l) y)) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y) (set-cdr! (cdr l) y)) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y) (set-cdr! (cddr l) y)) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cdr l) '())) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cddr l) '())) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cdr l) '())) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cddr l) '())) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cdr l) '())) '(a b c d) '(p q r s) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-each (lambda (x y z) (set-cdr! (cddr l) '())) '(a b c d) '(p q r s) l)))
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '())
(for-each p '() x1)
(for-each p '() x1 x2)
(for-each p '() x1 x2 x3)
(for-each p '() x1 x2 x3 x4)
(for-each p '() x1 x2 x3 x4 x5)
(for-each p x1 '())
(for-each p x1 '() x2)
(for-each p x1 '() x2 x3)
(for-each p x1 '() x2 x3 x4)
(for-each p x1 '() x2 x3 x4 x5)
(for-each p x1 x2 '())
(for-each p x1 x2 '() x3)
(for-each p x1 x2 '() x3 x4)
(for-each p x1 x2 '() x3 x4 x5)
(for-each p x1 x2 x3 '())
(for-each p x1 x2 x3 '() x4)
(for-each p x1 x2 x3 '() x4 x5)
(for-each p x1 x2 x3 x4 '())
(for-each p x1 x2 x3 x4 '() x5)
(for-each p x1 x2 x3 x4 x5 '())))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '() '() '() '() '())
(reverse ls))
'())
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '(a))
(for-each p '(a) x1)
(for-each p '(a) x1 x2)
(for-each p '(a) x1 x2 x3)
(for-each p '(a) x1 x2 x3 x4)
(for-each p '(a) x1 x2 x3 x4 x5)
(for-each p x1 '(a))
(for-each p x1 '(a) x2)
(for-each p x1 '(a) x2 x3)
(for-each p x1 '(a) x2 x3 x4)
(for-each p x1 '(a) x2 x3 x4 x5)
(for-each p x1 x2 '(a))
(for-each p x1 x2 '(a) x3)
(for-each p x1 x2 '(a) x3 x4)
(for-each p x1 x2 '(a) x3 x4 x5)
(for-each p x1 x2 x3 '(a))
(for-each p x1 x2 x3 '(a) x4)
(for-each p x1 x2 x3 '(a) x4 x5)
(for-each p x1 x2 x3 x4 '(a))
(for-each p x1 x2 x3 x4 '(a) x5)
(for-each p x1 x2 x3 x4 x5 '(a))))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '(1) '(f) '(k) '(p) '(u))
(reverse ls))
'((a) (1 a) (f 1 a) (k f 1 a) (p k f 1 a) (u p k f 1 a)
(a 1) (f a 1) (k f a 1) (p k f a 1) (u p k f a 1)
(a f 1) (k a f 1) (p k a f 1) (u p k a f 1) (a k f 1)
(p a k f 1) (u p a k f 1) (a p k f 1) (u a p k f 1)
(a u p k f 1)))
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '(a b))
(for-each p '(a b) x1)
(for-each p '(a b) x1 x2)
(for-each p '(a b) x1 x2 x3)
(for-each p '(a b) x1 x2 x3 x4)
(for-each p '(a b) x1 x2 x3 x4 x5)
(for-each p x1 '(a b))
(for-each p x1 '(a b) x2)
(for-each p x1 '(a b) x2 x3)
(for-each p x1 '(a b) x2 x3 x4)
(for-each p x1 '(a b) x2 x3 x4 x5)
(for-each p x1 x2 '(a b))
(for-each p x1 x2 '(a b) x3)
(for-each p x1 x2 '(a b) x3 x4)
(for-each p x1 x2 '(a b) x3 x4 x5)
(for-each p x1 x2 x3 '(a b))
(for-each p x1 x2 x3 '(a b) x4)
(for-each p x1 x2 x3 '(a b) x4 x5)
(for-each p x1 x2 x3 x4 '(a b))
(for-each p x1 x2 x3 x4 '(a b) x5)
(for-each p x1 x2 x3 x4 x5 '(a b))))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '(1 2) '(f g) '(k l) '(p q) '(u v))
(reverse ls))
'((a) (b) (1 a) (2 b) (f 1 a) (g 2 b) (k f 1 a)
(l g 2 b) (p k f 1 a) (q l g 2 b) (u p k f 1 a)
(v q l g 2 b) (a 1) (b 2) (f a 1) (g b 2) (k f a 1)
(l g b 2) (p k f a 1) (q l g b 2) (u p k f a 1)
(v q l g b 2) (a f 1) (b g 2) (k a f 1) (l b g 2)
(p k a f 1) (q l b g 2) (u p k a f 1) (v q l b g 2)
(a k f 1) (b l g 2) (p a k f 1) (q b l g 2)
(u p a k f 1) (v q b l g 2) (a p k f 1) (b q l g 2)
(u a p k f 1) (v b q l g 2) (a u p k f 1)
(b v q l g 2)))
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '(a b c))
(for-each p '(a b c) x1)
(for-each p '(a b c) x1 x2)
(for-each p '(a b c) x1 x2 x3)
(for-each p '(a b c) x1 x2 x3 x4)
(for-each p '(a b c) x1 x2 x3 x4 x5)
(for-each p x1 '(a b c))
(for-each p x1 '(a b c) x2)
(for-each p x1 '(a b c) x2 x3)
(for-each p x1 '(a b c) x2 x3 x4)
(for-each p x1 '(a b c) x2 x3 x4 x5)
(for-each p x1 x2 '(a b c))
(for-each p x1 x2 '(a b c) x3)
(for-each p x1 x2 '(a b c) x3 x4)
(for-each p x1 x2 '(a b c) x3 x4 x5)
(for-each p x1 x2 x3 '(a b c))
(for-each p x1 x2 x3 '(a b c) x4)
(for-each p x1 x2 x3 '(a b c) x4 x5)
(for-each p x1 x2 x3 x4 '(a b c))
(for-each p x1 x2 x3 x4 '(a b c) x5)
(for-each p x1 x2 x3 x4 x5 '(a b c))))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '(1 2 3) '(f g h) '(k l m) '(p q r) '(u v w))
(reverse ls))
'((a) (b) (c) (1 a) (2 b) (3 c) (f 1 a) (g 2 b) (h 3 c)
(k f 1 a) (l g 2 b) (m h 3 c) (p k f 1 a) (q l g 2 b)
(r m h 3 c) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
(a 1) (b 2) (c 3) (f a 1) (g b 2) (h c 3) (k f a 1)
(l g b 2) (m h c 3) (p k f a 1) (q l g b 2) (r m h c 3)
(u p k f a 1) (v q l g b 2) (w r m h c 3) (a f 1)
(b g 2) (c h 3) (k a f 1) (l b g 2) (m c h 3)
(p k a f 1) (q l b g 2) (r m c h 3) (u p k a f 1)
(v q l b g 2) (w r m c h 3) (a k f 1) (b l g 2)
(c m h 3) (p a k f 1) (q b l g 2) (r c m h 3)
(u p a k f 1) (v q b l g 2) (w r c m h 3) (a p k f 1)
(b q l g 2) (c r m h 3) (u a p k f 1) (v b q l g 2)
(w c r m h 3) (a u p k f 1) (b v q l g 2)
(c w r m h 3)))
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '(a b c d))
(for-each p '(a b c d) x1)
(for-each p '(a b c d) x1 x2)
(for-each p '(a b c d) x1 x2 x3)
(for-each p '(a b c d) x1 x2 x3 x4)
(for-each p '(a b c d) x1 x2 x3 x4 x5)
(for-each p x1 '(a b c d))
(for-each p x1 '(a b c d) x2)
(for-each p x1 '(a b c d) x2 x3)
(for-each p x1 '(a b c d) x2 x3 x4)
(for-each p x1 '(a b c d) x2 x3 x4 x5)
(for-each p x1 x2 '(a b c d))
(for-each p x1 x2 '(a b c d) x3)
(for-each p x1 x2 '(a b c d) x3 x4)
(for-each p x1 x2 '(a b c d) x3 x4 x5)
(for-each p x1 x2 x3 '(a b c d))
(for-each p x1 x2 x3 '(a b c d) x4)
(for-each p x1 x2 x3 '(a b c d) x4 x5)
(for-each p x1 x2 x3 x4 '(a b c d))
(for-each p x1 x2 x3 x4 '(a b c d) x5)
(for-each p x1 x2 x3 x4 x5 '(a b c d))))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '(1 2 3 4) '(f g h i) '(k l m n) '(p q r s) '(u v w x))
(reverse ls))
'((a) (b) (c) (d) (1 a) (2 b) (3 c) (4 d) (f 1 a)
(g 2 b) (h 3 c) (i 4 d) (k f 1 a) (l g 2 b) (m h 3 c)
(n i 4 d) (p k f 1 a) (q l g 2 b) (r m h 3 c)
(s n i 4 d) (u p k f 1 a) (v q l g 2 b) (w r m h 3 c)
(x s n i 4 d) (a 1) (b 2) (c 3) (d 4) (f a 1) (g b 2)
(h c 3) (i d 4) (k f a 1) (l g b 2) (m h c 3) (n i d 4)
(p k f a 1) (q l g b 2) (r m h c 3) (s n i d 4)
(u p k f a 1) (v q l g b 2) (w r m h c 3) (x s n i d 4)
(a f 1) (b g 2) (c h 3) (d i 4) (k a f 1) (l b g 2)
(m c h 3) (n d i 4) (p k a f 1) (q l b g 2) (r m c h 3)
(s n d i 4) (u p k a f 1) (v q l b g 2) (w r m c h 3)
(x s n d i 4) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
(p a k f 1) (q b l g 2) (r c m h 3) (s d n i 4)
(u p a k f 1) (v q b l g 2) (w r c m h 3) (x s d n i 4)
(a p k f 1) (b q l g 2) (c r m h 3) (d s n i 4)
(u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
(a u p k f 1) (b v q l g 2) (c w r m h 3)
(d x s n i 4)))
(begin
(define ($for-each-f1 p x1 x2 x3 x4 x5)
(begin
(for-each p '(a b c d e))
(for-each p '(a b c d e) x1)
(for-each p '(a b c d e) x1 x2)
(for-each p '(a b c d e) x1 x2 x3)
(for-each p '(a b c d e) x1 x2 x3 x4)
(for-each p '(a b c d e) x1 x2 x3 x4 x5)
(for-each p x1 '(a b c d e))
(for-each p x1 '(a b c d e) x2)
(for-each p x1 '(a b c d e) x2 x3)
(for-each p x1 '(a b c d e) x2 x3 x4)
(for-each p x1 '(a b c d e) x2 x3 x4 x5)
(for-each p x1 x2 '(a b c d e))
(for-each p x1 x2 '(a b c d e) x3)
(for-each p x1 x2 '(a b c d e) x3 x4)
(for-each p x1 x2 '(a b c d e) x3 x4 x5)
(for-each p x1 x2 x3 '(a b c d e))
(for-each p x1 x2 x3 '(a b c d e) x4)
(for-each p x1 x2 x3 '(a b c d e) x4 x5)
(for-each p x1 x2 x3 x4 '(a b c d e))
(for-each p x1 x2 x3 x4 '(a b c d e) x5)
(for-each p x1 x2 x3 x4 x5 '(a b c d e))))
(procedure? $for-each-f1))
(equal?
(let ([ls '()])
(define q (lambda args (set! ls (cons (reverse args) ls))))
($for-each-f1 q '(1 2 3 4 5) '(f g h i j) '(k l m n o) '(p q r s t) '(u v w x y))
(reverse ls))
'((a) (b) (c) (d) (e) (1 a) (2 b) (3 c) (4 d) (5 e)
(f 1 a) (g 2 b) (h 3 c) (i 4 d) (j 5 e) (k f 1 a)
(l g 2 b) (m h 3 c) (n i 4 d) (o j 5 e) (p k f 1 a)
(q l g 2 b) (r m h 3 c) (s n i 4 d) (t o j 5 e)
(u p k f 1 a) (v q l g 2 b) (w r m h 3 c) (x s n i 4 d)
(y t o j 5 e) (a 1) (b 2) (c 3) (d 4) (e 5) (f a 1)
(g b 2) (h c 3) (i d 4) (j e 5) (k f a 1) (l g b 2)
(m h c 3) (n i d 4) (o j e 5) (p k f a 1) (q l g b 2)
(r m h c 3) (s n i d 4) (t o j e 5) (u p k f a 1)
(v q l g b 2) (w r m h c 3) (x s n i d 4) (y t o j e 5)
(a f 1) (b g 2) (c h 3) (d i 4) (e j 5) (k a f 1)
(l b g 2) (m c h 3) (n d i 4) (o e j 5) (p k a f 1)
(q l b g 2) (r m c h 3) (s n d i 4) (t o e j 5)
(u p k a f 1) (v q l b g 2) (w r m c h 3) (x s n d i 4)
(y t o e j 5) (a k f 1) (b l g 2) (c m h 3) (d n i 4)
(e o j 5) (p a k f 1) (q b l g 2) (r c m h 3)
(s d n i 4) (t e o j 5) (u p a k f 1) (v q b l g 2)
(w r c m h 3) (x s d n i 4) (y t e o j 5) (a p k f 1)
(b q l g 2) (c r m h 3) (d s n i 4) (e t o j 5)
(u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
(y e t o j 5) (a u p k f 1) (b v q l g 2) (c w r m h 3)
(d x s n i 4) (e y t o j 5)))
;; cp0 optimizations for for-each
;; for-each with an empty list(s) always (void)
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
;; remove for-each the expression only if the procedure
;; has the correct arity and can't raise an error
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each list '(5 4 3 2 1 0))))
'(#2%void))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each box? '(5 4 3 2 1 0))))
'(#2%void))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each unbox '(5 4 3 2 1 0))))
'(#2%void)))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each cons '(5 4 3 2 1 0))))
'(#2%void)))
;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
;; avoid creating each list and doing the actual for-each
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
(list 1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(begin (#2%display 12) (#2%display 15) (#2%display 18)))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
(list 1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(begin (#3%display 12) (#3%display 15) (#3%display 18)))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
'(1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(begin (#2%display 12) (#2%display 15) (#2%display 18)))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
'(1 2 3)
(list 4 5 6)
(list '(7) '(8) '(9)))))
'(begin (#3%display 12) (#3%display 15) (#3%display 18)))
(equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
'(1 2 3)
'(4 5 6)
'((7) (8) (9)))))
'(begin (#2%display 12) (#2%display 15) (#2%display 18)))
(equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize
'(for-each (lambda (x y z) (display (apply + x y z)))
'(1 2 3)
'(4 5 6)
'((7) (8) (9)))))
'(begin (#3%display 12) (#3%display 15) (#3%display 18)))
(equal?
(with-output-to-string
(lambda ()
(for-each (begin (write 'ab) (lambda (x y) (write (cons x y))))
(begin (write 'a) (list (begin (write 'b) 'c)))
(begin (write 'a) (list (begin (write 'b) 'd))))))
"ababab(c . d)")
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(for-each (lambda (x y) (write (cons x y)))
(list (begin (write 'a) 'c) (begin (write 'b) 'd))
(list (begin (write 'x) 'e) (begin (write 'y) 'f)))))
; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby
'("abxy(c . e)(d . f)"
"abyx(c . e)(d . f)"
"baxy(c . e)(d . f)"
"bayx(c . e)(d . f)"
"xyab(c . e)(d . f)"
"yxab(c . e)(d . f)"
"xyba(c . e)(d . f)"
"yxba(c . e)(d . f)"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(for-each (lambda (x y z) (write (cons* x y z)))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
'("abcdef(g h . i)(j k . l)"
"abefcd(g h . i)(j k . l)"
"cdabef(g h . i)(j k . l)"
"cdefab(g h . i)(j k . l)"
"efabcd(g h . i)(j k . l)"
"efcdab(g h . i)(j k . l)"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(for-each (lambda (x y z) (write (cons* x y z)))
(begin (write 'ab) '(g j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
'("abcdef(g h . i)(j k . l)"
"abefcd(g h . i)(j k . l)"
"cdabef(g h . i)(j k . l)"
"cdefab(g h . i)(j k . l)"
"efabcd(g h . i)(j k . l)"
"efcdab(g h . i)(j k . l)"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(for-each (lambda (x y z) (write (cons* x y z)))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'cd) '(h k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
'("abcdef(g h . i)(j k . l)"
"abefcd(g h . i)(j k . l)"
"cdabef(g h . i)(j k . l)"
"cdefab(g h . i)(j k . l)"
"efabcd(g h . i)(j k . l)"
"efcdab(g h . i)(j k . l)"))
((lambda (x ls) (and (member x ls) #t))
(with-output-to-string
(lambda ()
(for-each (lambda (x y z) (write (cons* x y z)))
(begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'ef) '(i l)))))
'("abcdef(g h . i)(j k . l)"
"abefcd(g h . i)(j k . l)"
"cdabef(g h . i)(j k . l)"
"cdefab(g h . i)(j k . l)"
"efabcd(g h . i)(j k . l)"
"efcdab(g h . i)(j k . l)"))
)
(mat ormap
(ormap symbol? '(a b c d))
(ormap symbol? '(a 1 2 3))
(ormap symbol? '(1 2 3 a))
(not (ormap symbol? '()))
(not (ormap symbol? '(1 2 3 4)))
(ormap = '(1 2 3 4) '(1.1 2.0 3.1 4.1))
(not (ormap = '(1 2 3 4) '(1.1 2.2 3.3 4.4)))
(eqv? (ormap 1+ '(1 2 3 4)) 2)
(eqv? (ormap + '(1 2 3) '(3 4 5)) 4)
(ormap (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.3 4.4 6.4 8.6))
(not (ormap (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.3 4.4 6.5 8.6)))
(not (ormap (lambda (x y z) #t) '() '() '()))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (ormap x)))
(error? ; nonprocedure
(ormap 3 '()))
(error? ; nonprocedure
(ormap 3 '() '()))
(error? ; nonprocedure
(ormap 3 '(a b c)))
(error? ; improper list
(ormap not 'a))
(error? ; improper list
(ormap not '(a . b)))
(error? ; cyclic list
(ormap not '#1=(a . #1#)))
(error? ; length mismatch
(ormap (lambda (x y) #f) '(a b) '(p q r)))
(error? ; length mismatch
(ormap (lambda (x y z) #f) '(1 2) '(a b) '(p q r)))
(error? ; improper list
(ormap (lambda (x y) #f) 'a '(a b)))
(error? ; improper list
(ormap (lambda (x y) #f) '(a b) 'a))
(error? ; improper list
(ormap (lambda (x y) #f) '(a . b) '(a b)))
(error? ; improper list
(ormap (lambda (x y) #f) '(a b) '(a . b)))
(error? ; cyclic list
(ormap (lambda (x y) #f) '#1# '(a b c)))
(error? ; cyclic list
(ormap (lambda (x y) #f) '(a b c) '#1#))
(error? ; improper list
(ormap (lambda (x y z) #f) 'a '(a b) '(1 2)))
(error? ; improper list
(ormap (lambda (x y z) #f) '(a b) 'a '(1 2)))
(error? ; improper list
(ormap (lambda (x y z) #f) '(a b) '(1 2) 'a))
(error? ; improper list
(ormap (lambda (x y z) #f) '(a . b) '(a b) '(1 2)))
(error? ; improper list
(ormap (lambda (x y z) #f) '(a b) '(a . b) '(1 2)))
(error? ; improper list
(ormap (lambda (x y z) #f) '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(ormap (lambda (x y z) #f) '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(ormap (lambda (x y z) #f) '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(ormap (lambda (x y z) #f) '(a b c) '(1 2 3) '#1#))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x) (set-cdr! (cdr l) 1) #f) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x) (set-cdr! (cddr l) 1) #f) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y) (set-cdr! (cdr l) y) #f) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y) (set-cdr! (cddr l) y) #f) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y) (set-cdr! (cdr l) y) #f) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y) (set-cdr! (cddr l) y) #f) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) '(p q r s) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(ormap (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) '(p q r s) l)))
)
(mat andmap
(andmap symbol? '(a b c d))
(not (andmap symbol? '(a 1 2 3)))
(not (andmap symbol? '(1 2 3 a)))
(andmap symbol? '())
(not (andmap symbol? '(1 2 3 4)))
(andmap = '(1 2 3 4) '(1.0 2.0 3.0 4.0))
(not (andmap = '(1 2 3 4) '(1.0 2.0 3.3 4.0)))
(eqv? (andmap 1+ '(1 2 3 4)) 5)
(eqv? (andmap + '(1 2 3) '(3 4 5)) 8)
(andmap (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.2 4.3 6.4 8.5))
(not (andmap (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.2 4.3 6.5 8.5)))
(eq? (andmap (lambda (x y z) #t) '() '() '()) #t)
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (andmap x)))
(error? ; nonprocedure
(andmap 3 '()))
(error? ; nonprocedure
(andmap 3 '() '()))
(error? ; nonprocedure
(andmap 3 '(a b c)))
(error? ; improper list
(andmap values 'a))
(error? ; improper list
(andmap values '(a . b)))
(error? ; cyclic list
(andmap values '#1=(a . #1#)))
(error? ; length mismatch
(andmap (lambda (x y) #t) '(a b) '(p q r)))
(error? ; length mismatch
(andmap (lambda (x y z) #t) '(1 2) '(a b) '(p q r)))
(error? ; improper list
(andmap (lambda (x y) #t) 'a '(a b)))
(error? ; improper list
(andmap (lambda (x y) #t) '(a b) 'a))
(error? ; improper list
(andmap (lambda (x y) #t) '(a . b) '(a b)))
(error? ; improper list
(andmap (lambda (x y) #t) '(a b) '(a . b)))
(error? ; cyclic list
(andmap (lambda (x y) #t) '#1# '(a b c)))
(error? ; cyclic list
(andmap (lambda (x y) #t) '(a b c) '#1#))
(error? ; improper list
(andmap (lambda (x y z) #t) 'a '(a b) '(1 2)))
(error? ; improper list
(andmap (lambda (x y z) #t) '(a b) 'a '(1 2)))
(error? ; improper list
(andmap (lambda (x y z) #t) '(a b) '(1 2) 'a))
(error? ; improper list
(andmap (lambda (x y z) #t) '(a . b) '(a b) '(1 2)))
(error? ; improper list
(andmap (lambda (x y z) #t) '(a b) '(a . b) '(1 2)))
(error? ; improper list
(andmap (lambda (x y z) #t) '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(andmap (lambda (x y z) #t) '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(andmap (lambda (x y z) #t) '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(andmap (lambda (x y z) #t) '(a b c) '(1 2 3) '#1#))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x) (set-cdr! (cdr l) 1) #t) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x) (set-cdr! (cddr l) 1) #t) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y) (set-cdr! (cdr l) y) #t) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y) (set-cdr! (cddr l) y) #t) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y) (set-cdr! (cdr l) y) #t) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y) (set-cdr! (cddr l) y) #t) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) '(p q r s) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(andmap (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) '(p q r s) l)))
)
(mat exists
(exists symbol? '(a b c d))
(exists symbol? '(a 1 2 3))
(exists symbol? '(1 2 3 a))
(not (exists symbol? '()))
(not (exists symbol? '(1 2 3 4)))
(exists = '(1 2 3 4) '(1.1 2.0 3.1 4.1))
(not (exists = '(1 2 3 4) '(1.1 2.2 3.3 4.4)))
(eqv? (exists 1+ '(1 2 3 4)) 2)
(eqv? (exists + '(1 2 3) '(3 4 5)) 4)
(exists (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.3 4.4 6.4 8.6))
(not (exists (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.3 4.4 6.5 8.6)))
(not (exists (lambda (x y z) #t) '() '() '()))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (exists x)))
(error? ; nonprocedure
(exists 3 '()))
(error? ; nonprocedure
(exists 3 '() '()))
(error? ; nonprocedure
(exists 3 '(a b c)))
(error? ; improper list
(exists not 'a))
(error? ; improper list
(exists not '(a . b)))
(error? ; cyclic list
(exists not '#1=(a . #1#)))
(error? ; length mismatch
(exists (lambda (x y) #f) '(a b) '(p q r)))
(error? ; length mismatch
(exists (lambda (x y z) #f) '(1 2) '(a b) '(p q r)))
(error? ; improper list
(exists (lambda (x y) #f) 'a '(a b)))
(error? ; improper list
(exists (lambda (x y) #f) '(a b) 'a))
(error? ; improper list
(exists (lambda (x y) #f) '(a . b) '(a b)))
(error? ; improper list
(exists (lambda (x y) #f) '(a b) '(a . b)))
(error? ; cyclic list
(exists (lambda (x y) #f) '#1# '(a b c)))
(error? ; cyclic list
(exists (lambda (x y) #f) '(a b c) '#1#))
(error? ; improper list
(exists (lambda (x y z) #f) 'a '(a b) '(1 2)))
(error? ; improper list
(exists (lambda (x y z) #f) '(a b) 'a '(1 2)))
(error? ; improper list
(exists (lambda (x y z) #f) '(a b) '(1 2) 'a))
(error? ; improper list
(exists (lambda (x y z) #f) '(a . b) '(a b) '(1 2)))
(error? ; improper list
(exists (lambda (x y z) #f) '(a b) '(a . b) '(1 2)))
(error? ; improper list
(exists (lambda (x y z) #f) '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(exists (lambda (x y z) #f) '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(exists (lambda (x y z) #f) '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(exists (lambda (x y z) #f) '(a b c) '(1 2 3) '#1#))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x) (set-cdr! (cdr l) 1) #f) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x) (set-cdr! (cddr l) 1) #f) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y) (set-cdr! (cdr l) y) #f) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y) (set-cdr! (cddr l) y) #f) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y) (set-cdr! (cdr l) y) #f) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y) (set-cdr! (cddr l) y) #f) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cdr l) '()) #f) '(a b c d) '(p q r s) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(exists (lambda (x y z) (set-cdr! (cddr l) '()) #f) '(a b c d) '(p q r s) l)))
)
(mat for-all
(for-all symbol? '(a b c d))
(not (for-all symbol? '(a 1 2 3)))
(not (for-all symbol? '(1 2 3 a)))
(for-all symbol? '())
(not (for-all symbol? '(1 2 3 4)))
(for-all = '(1 2 3 4) '(1.0 2.0 3.0 4.0))
(not (for-all = '(1 2 3 4) '(1.0 2.0 3.3 4.0)))
(eqv? (for-all 1+ '(1 2 3 4)) 5)
(eqv? (for-all + '(1 2 3) '(3 4 5)) 8)
(for-all (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.2 4.3 6.4 8.5))
(not (for-all (lambda (x y z) (= (+ x y) z))
'(1 2 3 4)
'(1.2 2.3 3.4 4.5)
'(2.2 4.3 6.5 8.5)))
(eq? (for-all (lambda (x y z) #t) '() '() '()) #t)
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (for-all x)))
(error? ; nonprocedure
(for-all 3 '()))
(error? ; nonprocedure
(for-all 3 '() '()))
(error? ; nonprocedure
(for-all 3 '(a b c)))
(error? ; improper list
(for-all values 'a))
(error? ; improper list
(for-all values '(a . b)))
(error? ; cyclic list
(for-all values '#1=(a . #1#)))
(error? ; length mismatch
(for-all (lambda (x y) #t) '(a b) '(p q r)))
(error? ; length mismatch
(for-all (lambda (x y z) #t) '(1 2) '(a b) '(p q r)))
(error? ; improper list
(for-all (lambda (x y) #t) 'a '(a b)))
(error? ; improper list
(for-all (lambda (x y) #t) '(a b) 'a))
(error? ; improper list
(for-all (lambda (x y) #t) '(a . b) '(a b)))
(error? ; improper list
(for-all (lambda (x y) #t) '(a b) '(a . b)))
(error? ; cyclic list
(for-all (lambda (x y) #t) '#1# '(a b c)))
(error? ; cyclic list
(for-all (lambda (x y) #t) '(a b c) '#1#))
(error? ; improper list
(for-all (lambda (x y z) #t) 'a '(a b) '(1 2)))
(error? ; improper list
(for-all (lambda (x y z) #t) '(a b) 'a '(1 2)))
(error? ; improper list
(for-all (lambda (x y z) #t) '(a b) '(1 2) 'a))
(error? ; improper list
(for-all (lambda (x y z) #t) '(a . b) '(a b) '(1 2)))
(error? ; improper list
(for-all (lambda (x y z) #t) '(a b) '(a . b) '(1 2)))
(error? ; improper list
(for-all (lambda (x y z) #t) '(a b) '(1 2) '(a . b)))
(error? ; cyclic list
(for-all (lambda (x y z) #t) '#1# '(a b c) '(1 2 3)))
(error? ; cyclic list
(for-all (lambda (x y z) #t) '(a b c) '#1# '(1 2 3)))
(error? ; cyclic list
(for-all (lambda (x y z) #t) '(a b c) '(1 2 3) '#1#))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x) (set-cdr! (cdr l) 1) #t) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x) (set-cdr! (cddr l) 1) #t) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y) (set-cdr! (cdr l) y) #t) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y) (set-cdr! (cddr l) y) #t) l '(a b c d))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y) (set-cdr! (cdr l) y) #t) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y) (set-cdr! (cddr l) y) #t) '(a b c d) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) l '(a b c d) '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) l '(p q r s))))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cdr l) '()) #t) '(a b c d) '(p q r s) l)))
(error? ; input list mutated
(let ((l (list 1 2 3 4)))
(for-all (lambda (x y z) (set-cdr! (cddr l) '()) #t) '(a b c d) '(p q r s) l)))
)
(mat do
(do ((i 5 (1- i)) (j 1 (* i j))) ((zero? i) (= j 120)))
(do ((a 3) (i 20 (1- i))) ((zero? i) (= a 23)) (set! a (1+ a)))
)
;;; section 4-6:
(mat call/cc
(call/cc procedure?)
(equal? (call/cc (lambda (x) (+ 3 (x "hi")))) "hi")
(eq? (let ([l (call/cc
(lambda (ret)
(call/cc (lambda (l) (ret l)))
(lambda (x) 'hi)))])
(l #f))
'hi)
(((call/cc call/cc) (lambda (x) x)) #t)
(let ()
(define f
(lambda (n)
(let f ((n n))
(or (fx= n 0)
(and (call/cc (lambda (k) k))
(f (fx- n 1)))))))
(f 100000))
(let ()
(define f
(lambda (n)
(let f ((n n))
(or (fx= n 0)
(and (call/cc (lambda (k) (k k)))
(f (fx- n 1)))))))
(f 100000))
(let f ((n 100000))
(or (= n 0)
(call/cc (lambda (k) (f (- n 1))))))
(eqv? (let f ((n 1000) (ks '()))
(if (= n 0)
((list-ref (reverse ks) 317) 0)
(call/cc (lambda (k) (- (f (- n 1) (cons k ks)) 1)))))
-317)
(call/cc (lambda (k) (call/cc (lambda (k1) (eq? k1 k)))))
(let f ((n 1000) (k #f))
(or (= n 0)
(call/cc
(lambda (k1)
(and (eq? k1 (or k k1))
(f (- n 1) k1))))))
(eqv? (let ()
(define (ctak-aux k x y z)
(cond ((not (< y x)) ;xy
(k z))
(else (call-with-current-continuation
(ctak-aux
k
(call-with-current-continuation
(lambda (k)
(ctak-aux k (- x 1) y z)))
(call-with-current-continuation
(lambda (k)
(ctak-aux k (- y 1) z x)))
(call-with-current-continuation
(lambda (k)
(ctak-aux k (- z 1) x y))))))))
(define (ctak x y z)
(call-with-current-continuation
(lambda (k)
(ctak-aux k x y z))))
(ctak 18 12 6))
7)
(eqv? (call-with-current-continuation
(lambda (exit)
(for-each
(lambda (x) (if (negative? x) (exit x)))
'(54 0 37 -3 245 19))
#t))
-3)
(equal?
(let ()
(define list-length
(lambda (obj)
(call-with-current-continuation
(lambda (return)
(letrec ([r
(lambda (obj)
(cond
[(null? obj) 0]
[(pair? obj) (+ (r (cdr obj)) 1)]
[else (return #f)]))])
(r obj))))))
(list (list-length '(1 2 3 4)) (list-length '(a b . c))))
'(4 #f))
(let ()
(define (next-leaf-generator obj eot)
(letrec ([return #f]
[cont
(lambda (x)
(recur obj)
(set! cont (lambda (x) (return eot)))
(cont #f))]
[recur
(lambda (obj)
(if (pair? obj)
(for-each recur obj)
(call-with-current-continuation
(lambda (c) (set! cont c) (return obj)))))])
(lambda ()
(call-with-current-continuation
(lambda (ret) (set! return ret) (cont #f))))))
(define (leaf-eq? x y)
(let* ([eot (list 'eot)]
[xf (next-leaf-generator x eot)]
[yf (next-leaf-generator y eot)])
(letrec ([loop
(lambda (x y)
(cond
[(not (eq? x y)) #f]
[(eq? eot x) #t]
[else (loop (xf) (yf))]))])
(loop (xf) (yf)))))
(and (eq? (leaf-eq? '(a (b (c))) '((a) b c)) #t)
(eq? (leaf-eq? '(a (b (c))) '((a) b c d)) #f)))
)
(mat dynamic-wind
(let ([x 3])
(and (eqv? x 3)
(eqv? (dynamic-wind
(lambda () (set! x 4))
(lambda () x)
(lambda () (set! x 10)))
4)
(eqv? x 10)))
(let ([x 3])
(and (eqv? x 3)
(eqv? (call/cc
(lambda (l)
(dynamic-wind
(lambda () (set! x 4))
(lambda () (l x))
(lambda () (set! x 10)))
(set! x 20)))
4)
(eqv? x 10)))
(equal? (let* ([x 3]
[l (call/cc
(lambda (ret)
(dynamic-wind
(lambda () (set! x (1+ x)))
(lambda ()
(call/cc (lambda (l) (ret l)))
(let ([y x]) (lambda (n) (list n y))))
(lambda () (set! x (1- x))))))])
(l x))
'(3 4))
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind
(lambda () #f)
(lambda () (k2 0))
(lambda () (k1 0)))))
1)))
0)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind
(lambda () #f)
(lambda () (k1 0))
(lambda () (k2 0)))))
1)))
1)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind
(lambda () (k2 0))
(lambda () (k2 10))
(lambda () (k2 20)))))
1)))
1)
(equal?
(let ((p (open-output-string)))
(if (call/cc
(lambda (k)
(dynamic-wind
(lambda () (display "E" p))
(lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
(lambda () (display "I" p)))))
(*k1 #f)
(display "O" p))
(get-output-string p))
"EIEIO")
; once again for critical dynamic wind
(let ([x 3])
(and (eqv? x 3)
(eqv? (dynamic-wind #t
(lambda () (set! x 4))
(lambda () x)
(lambda () (set! x 10)))
4)
(eqv? x 10)))
(let ([x 3])
(and (eqv? x 3)
(eqv? (call/cc
(lambda (l)
(dynamic-wind #t
(lambda () (set! x 4))
(lambda () (l x))
(lambda () (set! x 10)))
(set! x 20)))
4)
(eqv? x 10)))
(equal? (let* ([x 3]
[l (call/cc
(lambda (ret)
(dynamic-wind #t
(lambda () (set! x (1+ x)))
(lambda ()
(call/cc (lambda (l) (ret l)))
(let ([y x]) (lambda (n) (list n y))))
(lambda () (set! x (1- x))))))])
(l x))
'(3 4))
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind #t
(lambda () #f)
(lambda () (k2 0))
(lambda () (k1 0)))))
1)))
0)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind #t
(lambda () #f)
(lambda () (k1 0))
(lambda () (k2 0)))))
1)))
1)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(dynamic-wind #t
(lambda () (k2 0))
(lambda () (k2 10))
(lambda () (k2 20)))))
1)))
1)
(equal?
(let ((p (open-output-string)))
(if (call/cc
(lambda (k)
(dynamic-wind #t
(lambda () (display "E" p))
(lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
(lambda () (display "I" p)))))
(*k1 #f)
(display "O" p))
(get-output-string p))
"EIEIO")
; make sure interrupts are enabled with error in critical dynamic wind
(error? (dynamic-wind #t (lambda () gook) void void))
(and (= (disable-interrupts) 1)
(= (enable-interrupts) 0))
(error? (dynamic-wind #t void void (lambda () gook)))
(and (= (disable-interrupts) 1)
(= (enable-interrupts) 0))
(error? ((call/cc
(lambda (k)
(let ([first? #t])
(dynamic-wind #t
(lambda () (if first? (set! first? #f) gook))
(lambda () (call/cc k))
void))))))
(and (= (disable-interrupts) 1)
(= (enable-interrupts) 0))
(error? (call/cc
(lambda (k)
(let ([first? #t])
(dynamic-wind #t
void
k
(lambda () gook))))))
(and (= (disable-interrupts) 1)
(= (enable-interrupts) 0))
)
(mat r6rs:dynamic-wind
(let ([x 3])
(and (eqv? x 3)
(eqv? (r6rs:dynamic-wind
(lambda () (set! x 4))
(lambda () x)
(lambda () (set! x 10)))
4)
(eqv? x 10)))
(let ([x 3])
(and (eqv? x 3)
(eqv? (call/cc
(lambda (l)
(r6rs:dynamic-wind
(lambda () (set! x 4))
(lambda () (l x))
(lambda () (set! x 10)))
(set! x 20)))
4)
(eqv? x 10)))
(equal? (let* ([x 3]
[l (call/cc
(lambda (ret)
(r6rs:dynamic-wind
(lambda () (set! x (1+ x)))
(lambda ()
(call/cc (lambda (l) (ret l)))
(let ([y x]) (lambda (n) (list n y))))
(lambda () (set! x (1- x))))))])
(l x))
'(3 4))
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(r6rs:dynamic-wind
(lambda () #f)
(lambda () (k2 0))
(lambda () (k1 0)))))
1)))
0)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(r6rs:dynamic-wind
(lambda () #f)
(lambda () (k1 0))
(lambda () (k2 0)))))
1)))
1)
(eqv? (call/cc
(lambda (k1)
(+ (call/cc
(lambda (k2)
(r6rs:dynamic-wind
(lambda () (k2 0))
(lambda () (k2 10))
(lambda () (k2 20)))))
1)))
1)
(equal?
(let ((p (open-output-string)))
(if (call/cc
(lambda (k)
(r6rs:dynamic-wind
(lambda () (display "E" p))
(lambda () (call/cc (lambda (k1) (set! *k1 k1) (k #t))))
(lambda () (display "I" p)))))
(*k1 #f)
(display "O" p))
(get-output-string p))
"EIEIO")
)
(mat call/1cc
(call/1cc procedure?)
(equal? (call/cc (lambda (x) (+ 3 (x "hi")))) "hi")
(((call/1cc call/cc) (lambda (x) x)) #t)
(((call/cc call/1cc) (lambda (x) x)) #t)
(error?
(parameterize ((collect-request-handler void))
((let f ((n 100))
(if (= n 0)
(call/1cc
(lambda (k)
(rec me
(case-lambda
[() me]
[(x) (k x)]))))
((call/1cc (lambda (k) (f (- n 1)))))))
(rec me
(case-lambda
[() me]
[(x) #t])))))
(parameterize ((collect-request-handler void))
((let f ((n 100))
(if (= n 0)
(call/cc
(lambda (k)
(rec me
(case-lambda
[() me]
[(x) (k x)]))))
((call/1cc (lambda (k) (f (- n 1)))))))
(rec me
(case-lambda
[() me]
[(x) #t]))))
(let ()
(define f
(lambda (n)
(let f ((n n))
(or (fx= n 0)
(and (call/cc (lambda (k) (k k)))
(f (fx- n 1)))))))
(f 100000))
(let f ((n 100000))
(or (= n 0)
(call/1cc (lambda (k) (f (- n 1))))))
(eqv? (let f ((n 1000) (ks '()))
(if (= n 0)
((list-ref (reverse ks) 317) 0)
(call/1cc (lambda (k) (- (f (- n 1) (cons k ks)) 1)))))
-317)
(call/1cc (lambda (k) (call/1cc (lambda (k1) (eq? k1 k)))))
(call/1cc (lambda (k) (call/cc (lambda (k1) (eq? k1 k)))))
(call/cc (lambda (k) (call/1cc (lambda (k1) (eq? k1 k)))))
(let f ((n 1000) (k #f))
(or (= n 0)
(call/1cc
(lambda (k1)
(and (eq? k1 (or k k1))
(f (- n 1) k1))))))
(eqv? (let ()
(define (ctak-aux k x y z)
(cond ((not (< y x)) ;xy
(k z))
(else (call/1cc
(ctak-aux
k
(call/1cc
(lambda (k)
(ctak-aux k (- x 1) y z)))
(call/1cc
(lambda (k)
(ctak-aux k (- y 1) z x)))
(call/1cc
(lambda (k)
(ctak-aux k (- z 1) x y))))))))
(define (ctak x y z)
(call/1cc
(lambda (k)
(ctak-aux k x y z))))
(ctak 18 12 6))
7)
(let ([x 3])
(and (eqv? x 3)
(eqv? (call/1cc
(lambda (l)
(dynamic-wind
(lambda () (set! x 4))
(lambda () (l x))
(lambda () (set! x 10)))
(set! x 20)))
4)
(eqv? x 10)))
(equal? (let* ([x 3]
[l (call/cc
(lambda (ret)
(dynamic-wind
(lambda () (set! x (1+ x)))
(lambda ()
(call/1cc (lambda (l) (ret l)))
(let ([y x]) (lambda (n) (list n y))))
(lambda () (set! x (1- x))))))])
(l x))
'(3 4))
(eqv? (call/1cc
(lambda (k1)
(+ (call/1cc
(lambda (k2)
(dynamic-wind
(lambda () #f)
(lambda () (k2 0))
(lambda () (k1 0)))))
1)))
0)
(eqv? (call/1cc
(lambda (k1)
(+ (call/1cc
(lambda (k2)
(dynamic-wind
(lambda () #f)
(lambda () (k1 0))
(lambda () (k2 0)))))
1)))
1)
(eqv? (call/1cc
(lambda (k1)
(+ (call/1cc
(lambda (k2)
(dynamic-wind
(lambda () (k2 0))
(lambda () (k2 10))
(lambda () (k2 20)))))
1)))
1)
(equal?
(let ((p (open-output-string)))
(if (call/cc
(lambda (k)
(dynamic-wind
(lambda () (display "E" p))
(lambda () (call/1cc (lambda (k1) (set! *k1 k1) (k #t))))
(lambda () (display "I" p)))))
(*k1 #f)
(display "O" p))
(get-output-string p))
"EIEIO")
)
;;; section 4-7:
(mat engine
(letrec ([ee (make-engine
(lambda ()
(map 1+ '(1 2 3 4 5 6 7 8 9))))]
[foo (lambda (n e)
(if (zero? n)
'()
(e n
(lambda (x y) (foo (1- n) ee))
(lambda (e) (foo n e)))))]
[goo (lambda (n)
(if (zero? n)
'okay
(begin (foo n ee) (goo (1- n)))))])
(eq? (goo 20) 'okay))
(let ([e (make-engine (lambda () (engine-block) (engine-return 'hi)))])
(e 10000
(lambda (x y) #f)
(lambda (e1)
(e1 10000
(lambda (t x) (eq? x 'hi))
(lambda (e) #f)))))
(equal? (let ([e (make-engine (lambda () (engine-block) (values 1 2 3)))])
(e 10000
(lambda (x . y) #f)
(lambda (e1)
(e1 10000
(lambda (t . x) x)
(lambda (e) #f)))))
'(1 2 3))
(eqv?
(let ([e (make-engine (lambda () (raise 'hello)))])
(guard (c [else c])
(e 1000 list values)))
'hello)
(eqv?
(let ([e (make-engine (lambda () (raise-continuable 'hello)))])
(with-exception-handler
(lambda (c) 17)
(lambda () (e 1000 (lambda (x y) y) values))))
17)
(eqv?
(let ([e (make-engine
(lambda ()
(let ([x (raise-continuable 'hello)])
(define fib
(lambda (x)
(if (<= x 1)
1
(+ (fib (- x 1)) (fib (- x 2))))))
(cons x (fib 20)))))])
(with-exception-handler
(lambda (c) (and (eq? c 'hello) 17))
(lambda ()
(e 1000 (lambda (x y) y) (lambda (x) 'stalled)))))
'stalled)
(equal?
(let ([e (make-engine
(lambda ()
(let ([x (raise-continuable 'hello)])
(define fib
(lambda (x)
(if (<= x 1)
1
(+ (fib (- x 1)) (fib (- x 2))))))
(cons x (fib 20)))))])
(with-exception-handler
(lambda (c) (and (eq? c 'hello) 17))
(lambda ()
(e 1000
(lambda (x y) 'oops1)
(lambda (e)
(e 1000
(lambda (x y) 'oops2)
(lambda (e)
(e 1000000
(lambda (x y) y)
values))))))))
'(17 . 10946))
(equal?
(let* ([e0 (make-engine
(lambda ()
(define fib
(lambda (x)
(if (<= x 1)
1
(+ (fib (- x 1)) (fib (- x 2))))))
(let ([n (fib 20)])
(cons n (raise-continuable 'hello)))))]
[e1 (with-exception-handler
(lambda (c) 'stuff1)
(lambda ()
(e0 1000
(lambda (x y) 'oops1)
(lambda (e) e))))]
[e2 (with-exception-handler
(lambda (c) 'stuff2)
(lambda ()
(e1 1000
(lambda (x y) 'oops2)
(lambda (e) e))))])
(with-exception-handler
(lambda (c) 'stuff3)
(lambda ()
(e2 1000000
(lambda (x y) y)
(lambda (e) e)))))
'(10946 . stuff3))
(let ()
(define spin
(letrec ((spin
(lambda (n m)
(cond
((= n 0) m)
(else (spin (- n 1) (+ m 1)))))))
(lambda (n)
(spin n 0))))
(define test6B/counter
(lambda (ticks th)
(define bytes (bytes-allocated))
(define counter 0)
(let loop ([e (make-engine th)])
(call-with-values
(lambda () (e ticks values values))
(case-lambda
[(left v) v]
[(e)
(set! counter (add1 counter))
(when (zero? (remainder counter 100000))
(collect (collect-maximum-generation))
(let ([% 20] [new-bytes (bytes-allocated)])
(when (> new-bytes (* bytes (+ 1 (/ % 100))))
(errorf 'test6B/counter "bytes allocated has grown by more than ~s% from ~s to ~s"
% bytes new-bytes))))
(loop e)])))))
(let ([n 100000000])
(eqv?
(test6B/counter 125 (lambda () (spin n)))
n)))
)
;;; section 4-8:
(mat delay-force ;;; from The Scheme Programming Language
(letrec ([stream-car
(lambda (s)
(car (force s)))]
[stream-cdr
(lambda (s)
(cdr (force s)))]
[stream-add
(lambda (s1 s2)
(delay
(cons (+ (stream-car s1) (stream-car s2))
(stream-add (stream-cdr s1) (stream-cdr s2)))))])
(let ([counters
(let next ([n 1])
(delay (cons n (next (+ n 1)))))])
(and (eqv? (stream-car counters) 1)
(eqv? (stream-car (stream-cdr counters)) 2)
(let ([even-counters (stream-add counters counters)])
(and (eqv? (stream-car even-counters) 2)
(eqv? (stream-car (stream-cdr even-counters)) 4))))))
(equal? (let ([x 0])
(let ([y (delay (begin (set! x 1) (values)))])
(let ([z x])
(force y)
(list x z))))
'(1 0))
; test for common delay/force bug posted to comp.lang.scheme; we had
; this for a short while after delay/force were extended to handle
; multiple values
(eq? (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
(c #f))
(force p))
3)
)
;;; no section ...
(mat make-guardian
(procedure? make-guardian)
(with-interrupts-disabled
(let ([x (make-guardian)])
(and (not (x))
(begin (x (cons 'a 'b)) (not (x)))
(begin (collect) (equal? (x) '(a . b)))
(not (x)))))
(with-interrupts-disabled
(let ([x1 (make-guardian)])
; counting on a little compiler cleanliness here...
(let ([x2 (make-guardian)])
(x1 x2)
(x2 x2))
(collect)
(let ([x2 (x1)])
(and (equal? (x2) x2)
(not (x1))
(not (x2))))))
(parameterize ([collect-trip-bytes (expt 2 24)])
(let ([k 1000000])
(let ([g (make-guardian)])
(let f ([n k])
(unless (= n 0)
(g (cons 3 4))
(let f () (cond [(g) => (lambda (x) (g x) (f))]))
(f (- n 1))))
(let f ([n k])
(unless (= n 0)
(cond
[(g) => (lambda (x) (f (- n 1)))]
[else (collect) (f n)])))
#t)))
(with-interrupts-disabled
(let ([x (make-guardian)])
(and (not (x))
(begin (x (cons 'a 'b) 'calvin) (not (x)))
(begin (collect) (equal? (x) 'calvin))
(not (x)))))
(with-interrupts-disabled
(let ([x (make-guardian)])
(and (not (x))
(begin (x (cons 'a 'b) (cons 'calvin 'hobbes)) (not (x)))
(begin (collect) (equal? (x) '(calvin . hobbes)))
(not (x)))))
(with-interrupts-disabled
(let ([x (make-guardian)])
(and (not (x))
(begin (x (cons 'a 'b) 17) (not (x)))
(begin (collect) (equal? (x) '17))
(not (x)))))
(equal?
(with-interrupts-disabled
(let ([g1 (make-guardian)] [g2 (make-guardian)])
(let ([p (list 'a 'b)])
(g1 p g2)
(g2 (list 'c 'd))
(collect 0 0)
(let ([p (cdr p)])
(collect 0 0)
(list ((g1)) p)))))
'((c d) (b)))
(eq? (with-interrupts-disabled
(let* ([g (make-guardian)] [x (list 'a 'b)])
(g x)
(collect 0 0)
(#%$keep-live x)
(g)))
#f)
(or (not (threaded?))
(equal?
(parameterize ([collect-request-handler void])
(let ([g (make-guardian)])
(fork-thread (lambda () (g (list 'a 'b))))
(let f () (when (> (length (#%$thread-list)) 1) (f)))
(collect)
(g)))
'(a b)))
(parameterize ([collect-request-handler void] [enable-object-counts #t])
(define-record-type fraz (fields zle))
(define g (make-guardian))
(define x (make-fraz 17))
(g x)
(collect 0 0)
(unless (let ([a (assq 'guardian (object-counts))])
(and a (assq 0 (cdr a))))
(error #f "no generation 0 guardian in object-counts list"))
(unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
(and a (assq 0 (cdr a))))
(error #f "no generation 0 fraz in object-counts list"))
(collect (collect-maximum-generation))
(unless (let ([a (assq 'guardian (object-counts))])
(and a (assq (collect-maximum-generation) (cdr a))))
(error #f "no maximum-generation guardian in object-counts list"))
(unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
(and a (assq (collect-maximum-generation) (cdr a))))
(error #f "no maximum-generation fraz in object-counts list"))
(collect (collect-maximum-generation) 'static)
(when (let ([a (assq 'guardian (object-counts))])
(and a (assq 'static (cdr a))))
(error #f "static-generation guardian in object-counts list"))
(unless (let ([a (assq (record-type-descriptor fraz) (object-counts))])
(and a (assq 'static (cdr a))))
(error #f "no static-generation fraz in object-counts list"))
(pretty-print (cons g x)) ; keep 'em live
#t)
(parameterize ([collect-request-handler void])
(define (get-all g) (let ([q (g)]) (if q (cons q (get-all g)) '())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(let ([g1 (make-guardian)] [g2 (make-guardian)])
(let ([x (box (cons 'a 'b))] [y (box (cons 'c 'd))])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x))
(g1 (unbox y))
(g2 (unbox x))
(g1 (unbox y))
(g1 (unbox x))
(collect 0 0)
(g2 (unbox x))
(g1 (cons 'e 'f))
(g2 (unbox x))
(g1 (unbox x))
(g2 (cons 'g 'h))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(unless (and (= (length q) 4) (equal? (remove '(g . h) q) (list (unbox x) (unbox x) (unbox x))))
(errorf #f "expected (unregister-guardian g2) to contain x = (a . b), x = (a . b), and (g . h), got ~s" q)))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(collect 0 0)
(insist equal? (get-all g1) '((e . f)))
(insist eq? (get-all g2) '())
(g2 (unbox x))
(set-box! x #f)
(collect 0 0)
(insist equal? (get-all g1) '((a . b) (a . b) (a . b)))
(insist equal? (get-all g2) '((a . b)))
(insist equal? (unregister-guardian g1) '((c . d) (c . d)))
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
#t)
)
(mat refcount-guardians
(error? ; unrecognized ftype
(ftype-guardian NO!))
(error? ; first element must be a word-sized integer with native endianness
(let ()
(define-ftype A (struct))
(ftype-guardian A)))
(error? ; first element must be a word-sized integer with native endianness
(let ()
(define-ftype A (union [u1 (struct (refcount char))] [u2 (struct (foo (* A)))]))
(ftype-guardian A)))
(error? ; invalid ftype-guardian argument
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(g (cons 'ka 'blooie))))
(error? ; invalid ftype-guardian argument
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(g (make-ftype-pointer iptr 0))))
(eq?
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian iptr))
(g (make-ftype-pointer A 0)))
(void))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 1))
(g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount uptr) (x int)))
(define g (ftype-guardian A))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a1 (make-ftype-pointer A addr))
(define a2 (make-ftype-pointer A addr))
(define wpa1 (weak-cons a1 '()))
(define wpa2 (weak-cons a2 '()))
(ftype-set! A (refcount) a1 0)
(ftype-set! A (x) a1 17)
(assert (eqv? (ftype-ref A (x) a1) 17))
(assert (eqv? (ftype-ref A (x) a2) 17))
(assert (eqv? (ftype-ref A (refcount) a1) 0))
(assert (eqv? (ftype-ref A (refcount) a2) 0))
(assert (not (ftype-locked-incr! A (refcount) a1)))
(assert (not (ftype-locked-incr! A (refcount) a2)))
(assert (eqv? (ftype-ref A (refcount) a1) 2))
(assert (eqv? (ftype-ref A (refcount) a2) 2))
(g a1)
(g a2)
(collect 0 0)
(assert (not (g)))
(set! a1 #f)
(collect 0 0)
(assert (not (g)))
(set! a2 #f)
(collect 0 0)
(set! a2 (g))
(assert (eq? (car wpa2) a2))
(assert (not (g)))
(assert (eqv? (ftype-ref A (refcount) a2) 0))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 1))
(regular-g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (regular-g)))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount uptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 2))
(regular-g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
(assert (not (regular-g)))
(assert (not (g)))
#t))
(with-interrupts-disabled
(let ()
(define-ftype A (struct (refcount iptr) (x int)))
(define g (ftype-guardian A))
(define regular-g (make-guardian))
(define addr (foreign-alloc (ftype-sizeof A)))
(define a (make-ftype-pointer A addr))
(ftype-set! A (refcount) a 0)
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (not (ftype-locked-incr! A (refcount) a)))
(assert (eqv? (ftype-ref A (refcount) a) 2))
(regular-g a)
(g a)
(g a)
(regular-g a)
(set! a #f)
(collect 0 0)
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
(assert (eqv? (ftype-ref A (refcount) (g)) 0))
(assert (not (regular-g)))
(assert (not (g)))
#t))
(parameterize ([collect-request-handler void])
(define-ftype A (struct (refcount iptr) (uid int)))
(define (get-all g)
(let ([a (g)])
(if a
(begin
(unless (eqv? (ftype-ref A (refcount) a) 0)
(errorf 'get-all "nonzero refcount ~s, uid ~s" (ftype-ref A (refcount) a) (ftype-ref A (uid) a)))
(cons a (get-all g)))
'())))
(module (insist)
(define ($insist e? expr expected got)
(unless (e? got expected)
(errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
(define-syntax insist
(syntax-rules ()
[(_ ?e? ?expr ?expected)
($insist ?e? '?expr ?expected ?expr)])))
(define (get-uid a) (ftype-ref A (uid) a))
(define (fritter addr refcount uid)
(let ([a (make-ftype-pointer A addr)])
(ftype-set! A (refcount) a refcount)
(ftype-set! A (uid) a uid)
(box a)))
(let ([x-addr (foreign-alloc (ftype-sizeof A))] [y-addr (foreign-alloc (ftype-sizeof A))] [z-addr (foreign-alloc (ftype-sizeof A))])
(let ([x1 (fritter x-addr 6 73)] [x2 (box (make-ftype-pointer A x-addr))] [y (fritter y-addr 2 57)] [z (fritter z-addr 2 91)])
(let ([g1 (ftype-guardian A)] [g2 (ftype-guardian A)])
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(g1 (unbox x1))
(g2 (unbox x1))
(g1 (unbox x1))
(g1 (unbox x2))
(g2 (unbox x1))
(g1 (unbox y))
(g1 (unbox y))
(g2 (unbox z))
(g1 (unbox z))
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(let ([q (unregister-guardian g2)])
(define (decr-refcount! a) (ftype-locked-decr! A (refcount) a))
(unless (and (= (length q) 3) (memq (unbox x1) (memq (unbox x1) q)) (memq (unbox z) q))
(errorf #f "expected (unregister-guardian g2) to contain x/uid 73, x/uid 73, and z/uid 91, got ~s" (map get-uid q)))
(map decr-refcount! q))
(insist eq? (unregister-guardian g2) '())
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(pretty-print z) ; keep it live
(set-box! z #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(91))
(insist eq? (get-all g2) '())
(g2 (unbox x1))
(pretty-print x1) ; keep it live
(set-box! x1 #f)
(collect 0 0)
(insist eq? (get-all g1) '())
(insist eq? (get-all g2) '())
(insist eq? (unregister-guardian g2) '())
(insist eqv? (ftype-ref A (refcount) (unbox x2)) 1)
(pretty-print x2) ; keep it live
(set-box! x2 #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(73))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print y) ; keep it live
(set-box! y #f)
(collect 0 0)
(insist equal? (map get-uid (get-all g1)) '(57))
(insist equal? (map get-uid (get-all g2)) '())
(insist eq? (unregister-guardian g1) '())
(insist eq? (unregister-guardian g2) '())
(pretty-print (list g1 g2 x y)))) ; keep 'em live
(foreign-free x-addr)
(foreign-free y-addr)
(foreign-free z-addr))
#t)
)
(mat weak-cons
(procedure? weak-cons)
(procedure? weak-pair?)
(with-interrupts-disabled
(let ([x (weak-cons (cons 'a 'b) 'c)])
(and (equal? (car x) '(a . b))
(begin (collect) (bwp-object? (car x)))
(begin (set-car! x (cons 'd 'e)) (equal? (car x) '(d . e)))
(begin (collect (collect-maximum-generation))
(bwp-object? (car x))))))
)
(mat ephemeron
(begin
(define ephemeron-key car)
(define ephemeron-value cdr)
(define gdn (make-guardian))
#t)
(ephemeron-pair? (ephemeron-cons 1 2))
(begin
;; ----------------------------------------
;; Check that the ephemeron value doesn't retain
;; itself as an epehemeron key
(define-values (es wps saved)
(let loop ([n 1000] [es '()] [wps '()] [saved '()])
(cond
[(zero? n)
(values es wps saved)]
[else
(let ([k1 (gensym)]
[k2 (gensym)])
(gdn k2)
(loop (sub1 n)
(cons (ephemeron-cons k1 (box k1))
(cons (ephemeron-cons k2 (box k2))
es))
(weak-cons k1 (weak-cons k2 wps))
(cons k1 saved)))])))
(collect (collect-maximum-generation))
;; All now waiting to be reported by the guardian
(let loop ([es es] [wps wps] [saved saved])
(cond
[(null? saved) #t]
[else
(and
(eq? (car saved) (car wps))
(eq? (car saved) (ephemeron-key (car es)))
(eq? (car saved) (unbox (ephemeron-value (car es))))
(eq? (cadr wps) (ephemeron-key (cadr es)))
(eq? (cadr wps) (unbox (ephemeron-value (cadr es))))
(loop (cddr es) (cddr wps) (cdr saved)))])))
(begin
;; Report each from the guardian:
(let loop ([saved saved])
(unless (null? saved)
(gdn)
(loop (cdr saved))))
(collect (collect-maximum-generation))
(let loop ([es es] [wps wps] [saved saved])
(cond
[(null? saved) #t]
[else
(and
(eq? (car saved) (car wps))
(eq? (car saved) (ephemeron-key (car es)))
(eq? (car saved) (unbox (ephemeron-value (car es))))
(eq? #!bwp (cadr wps))
(eq? #!bwp (ephemeron-key (cadr es)))
(eq? #!bwp (ephemeron-value (cadr es)))
(loop (cddr es) (cddr wps) (cdr saved)))])))
;; ----------------------------------------
;; Stress test to check that the GC doesn't suffer from quadratic
;; behavior
(let ()
(define (wrapper v) (list 1 2 3 4 5 v))
;; Create a chain of ephemerons where we have all
;; the the ephemerons immediately in a list,
;; but we discover the keys one at a time
(define (mk n prev-key es)
(cond
[(zero? n)
(values prev-key es)]
[else
(let ([key (gensym)])
(mk (sub1 n)
key
(cons (ephemeron-cons key (wrapper prev-key))
es)))]))
;; Create a chain of ephemerons where we have all
;; of the keys immediately in a list,
;; but we discover the ephemerons one at a time
(define (mk* n prev-e keys)
(cond
[(zero? n)
(values prev-e keys)]
[else
(let ([key (gensym)])
(mk* (sub1 n)
(ephemeron-cons key (wrapper prev-e))
(cons key
keys)))]))
(define (measure-time n keep-alive)
;; Hang the discover-keys-one-at-a-time chain
;; off the end of the discover-ephemerons-one-at-a-time
;; chain, which is the most complex case for avoiding
;; quadratic GC times
(parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)])
(collect 2)
(let*-values ([(key es) (mk n (gensym) '())]
[(root holds) (mk* n key es)])
(let ([start (current-time)])
(collect 0 1)
(collect 1 2)
(collect 2 2)
(let ([delta (time-difference (current-time) start)])
;; Sanity check on ephemerons
(for-each (lambda (e)
(when (eq? #!bwp (ephemeron-key e))
(error 'check "oops")))
es)
;; Keep `root` and `holds` live:
(keep-alive (cons root holds))
;; Return duration:
delta)))))
(define N 10000)
;; The first time should be roughy x10 the second (not x100)
(let loop ([tries 3])
(define dummy #f)
(define (keep-alive v) (set! dummy (cons dummy v)))
(define t1 (measure-time (* 10 N) keep-alive))
(define dummy2 (set! dummy #f))
(define t2 (measure-time N keep-alive))
(define (duration->inexact t) (+ (* (time-second t) 1e9)
(inexact (time-nanosecond t))))
(set! dummy #f)
(let ([t1 (duration->inexact t1)] [t2 (duration->inexact t2)])
(or (< (/ t1 t2) 20)
(begin
(printf "t1 = ~s, t2 = ~s, t1/t2 = ~s\n" t1 t2 (/ t1 t2))
(and (positive? tries)
(loop (sub1 tries))))))))
;; ----------------------------------------
;; Check interaction of mutation and generations
;; This check disables interrupts so that a garbage collection
;; happens only for the explicit `collect` request.
(with-interrupts-disabled
(let ([e (ephemeron-cons (gensym) 'ok)])
(collect 0) ; => `e` is moved to generation 1
(and
(eq? #!bwp (ephemeron-key e))
(eq? #!bwp (ephemeron-value e))
(let ([s (gensym)])
(set-car! e s)
(set-cdr! e 'ok-again)
(collect 0) ; => `s` is moved to generation 1
(and
(eq? s (ephemeron-key e))
(eq? 'ok-again (ephemeron-value e))
(begin
(set! s #f)
(collect 1) ; collect former `s`
(and
(eq? #!bwp (ephemeron-key e))
(eq? #!bwp (ephemeron-value e)))))))))
;; ----------------------------------------
;; Check interaction of mutation and incremental generation promotion
(parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)])
(let ([key "key"])
(let ([e (ephemeron-cons key #f)])
(collect 0 1 1)
(let ([key2 (gensym key)])
;; e is gen 1, key2 is gen 0:
(set-car! e key2)
(collect 1 1 2)
;; Now, e is gen 1, key2 is gen 0
(and (eq? (car e) key2)
(begin
(collect 1 2 2)
;; Check that the GC update the reference to `key2` in `e`:
(eq? (car e) key2)))))))
;; ----------------------------------------
;; Check fasl:
(let ([s (gensym)])
(define-values (o get) (open-bytevector-output-port))
(fasl-write (list s
(ephemeron-cons s 'ok))
o)
(let* ([l (fasl-read (open-bytevector-input-port (get)))]
[e (cadr l)])
(and
(eq? (car l) (ephemeron-key e))
(eq? 'ok (ephemeron-value e))
(begin
(set! s #f)
(set! l #f)
(collect (collect-maximum-generation))
(and
(eq? #!bwp (ephemeron-key e))
(eq? #!bwp (ephemeron-value e))))))))
(mat $primitive
(procedure? #%car)
(procedure? #2%car)
(procedure? #3%car)
(equal? '#%car '($primitive car))
(equal? '#2%car '($primitive 2 car))
(equal? '#3%car '($primitive 3 car))
(equal? (#%list 1 2 3) '(1 2 3))
(eqv? (#2%+ 1 2 3) 6)
(error? (#2%fx+ 'a))
(error? #3%fubar)
(error? (#2%car 'a 'b))
(error? (#2%car 3)))