4.ms

;;; 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"))
         ; 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)
 )

(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")
    (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)
 )

(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))
  )

(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 interrups 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 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)))