;;; 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)))
     '(if (begin (set! x y) (set! z y) (#2%zero? h)) e1 e2))

  (equivalent-expansion? 
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #f))) e1 e2)))
     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e1) (begin (set! l y) e2))))

  (equivalent-expansion? 
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #t) (begin (set! l y) #t))) e1 e2)))
     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e1))

  (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #f))) e1 e2)))
     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (set! l z) (set! l y)) e2))

  (equivalent-expansion? 
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize '(if (begin (set! x y) (if (begin (set! z y) (zero? h)) (begin (set! l z) #f) (begin (set! l y) #t))) e1 e2)))
     '(begin (set! x y) (if (begin (set! z y) (#2%zero? h)) (begin (set! l z) e2) (begin (set! l y) e1))))

 )

(mat when
   (= (let ((x 12)) (when (= x 12) (set! x 11) (set! x 1)) x) 1)
   (= (let ((x 12)) (when (= x 11) (set! x 11) (set! x 1)) x) 12)
 )

(mat unless
   (eq? (let ((y 'a)) (unless (eq? y 'b) (set! y 'c)) y) 'c)
   (eq? (let ((y 'a)) (unless (eq? y 'a) (set! y 'c)) y) 'a)
 )

(mat not
   (not #f)
   (not (not #t))
   (let ((x 3)) (set! x 4) (not (= x 3)))
 )

(mat and
   (not (let ((x 'x)) (set! x #f) (and x #t #t)))
   (eq? (let ((x 'x)) (and x (begin (set! x 'c) x) x)) 'c)
 )

(mat or
   (equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (cons x x) 3)) '(()))
   (equal? (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)) 3)) 3)
   (not (let ((x 'x)) (set! x '()) (or (eq? x 'x) (not (null? x)))))
   ; make sure the following isn't incorrectly recognized as an or
   (equal? (let ((x #f)) (if x x (cons x x))) '(#f . #f))
 )

(mat cond
  (error? ; invalid syntax
    (cond))
   (let ((a 'a))
      (and (begin (set! a 3)
                  (cond ((= a 4) #f) ((= a 3) #t) (else #f)))
           (begin (set! a 4)
                  (cond ((= a 4) #t) ((= a 3) #f) (else #f)))
           (begin (set! a 2)
                  (cond ((= a 4) #f) ((= a 3) #f) (else #t)))
           (begin (set! a 4)
                  (cond ((= a 4)) ((= a 3) #f) (else #f)))
           (begin (set! a 3)
                  (cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
   (eq? 'b (cond ((assq 'a '((a . b))) => cdr) (else #f)))
   (equal? '(b c) (cond ((memq 'b '(a b c))) (else #f)))
  ; make sure cond requires procedure on RHS of =>
   (error?
     (let () ; aziz's strange example
       (define-syntax x
         (syntax-rules ()
           ((_ t) (lambda (t) t))))
       ((cond (#t => x)) 18)))
 )

(mat exclusive-cond
   (error? ; invalid syntax
     (exclusive-cond [a . b]))
   (error? ; invalid syntax
     (exclusive-cond))
   (let ((a 'a))
      (and (begin (set! a 3)
                  (exclusive-cond ((= a 4) #f) ((= a 3) #t) (else #f)))
           (begin (set! a 4)
                  (exclusive-cond ((= a 4) #t) ((= a 3) #f) (else #f)))
           (begin (set! a 2)
                  (exclusive-cond ((= a 4) #f) ((= a 3) #f) (else #t)))
           (begin (set! a 4)
                  (exclusive-cond ((= a 4) => (lambda (x) x)) ((= a 3) #f) (else #f)))
           (begin (set! a 3)
                  (exclusive-cond ((= a 4) #f) ((= a 3) (= a 4) #t) (else #f)))))
   (eq? 'b (exclusive-cond ((assq 'a '((a . b))) => cdr) (else #f)))
   (equal? '(b c) (exclusive-cond ((memq 'b '(a b c)) => (lambda (x) x)) (else #f)))
  ; make sure exclusive-cond requires procedure on RHS of =>
   (error?
     (let () ; aziz's strange example
       (define-syntax x
         (syntax-rules ()
           ((_ t) (lambda (t) t))))
       ((exclusive-cond (#t => x)) 18)))
  ; verify that exclusive cond actually reorders with profile information available
   (begin
     (with-output-to-file "testfile.ss"
       (lambda ()
         (pretty-print
           '(let ()
              (define count1 0)
              (define count2 0)
              (define count3 0)
              (define count4 0)
              (define count5 0)
              (define foo
                (lambda (n)
                  (exclusive-cond
                    [(begin (set! count1 (+ count1 1)) (< n 5))
                     (set! count3 (+ count3 1))]
                    [(begin (set! count2 (+ count2 1)) (> n 5))
                     (set! count4 (+ count4 1))]
                    [else (set! count5 (+ count5 1))])))
              (do ([i 10 (fx- i 1)])
                ((fx= i 0))
                (foo 10))
              (foo 3)
              (pretty-print (list count1 count2 count3 count4 count5)))))
       'replace)
     (profile-clear-database)
     #t)
   (equal?
     (with-output-to-string
       (lambda ()
         ; make sure no collection occurs before profile data is dumped
         (parameterize ([compile-profile #t] [collect-request-handler void])
           (load "testfile.ss" compile)
           (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump))))
         ; make sure collections are restarted
         (collect)))
     "(11 10 1 10 0)\n")
   (begin
     (profile-load-data "testfile.pd")
     #t)
   (equal?
     (with-output-to-string
       (lambda ()
         (load "testfile.ss" compile)))
     "(1 11 1 10 0)\n")
   (begin
     (profile-clear-database)
     #t)
   (begin
     (profile-load-data "testfile.pd" "testfile.pd")
     #t)
   (equal?
     (with-output-to-string
       (lambda ()
         (load "testfile.ss" compile)))
     "(1 11 1 10 0)\n")
   (begin
     (profile-clear-database)
     #t)
 )

(mat case
  (error? ; invalid syntax
    (case 3 [a . b]))
  (eq? (case 'a [a 'yes] [b 'no]) 'yes)
  (let ((a 'a))
    (and
      (begin (set! a 'a)
        (case a (a #t) ((b c) #f))
        (case a (a #t) ((b c) #f) (else #f)))
      (begin (set! a 'b)
        (case a (a #f) ((b c) #t))
        (case a (a #f) ((b c) #t) (else #f)))
      (begin (set! a 'c)
        (case a (a #f) ((b c) #t))
        (case a (a #f) ((b c) #t) (else #f)))
      (begin (set! a 'd)
        (case a (a #f) ((b c) #f) (else #t)))))
  (let ([f (lambda (x)
             (case x
               (#\a 'case1)
               (1/2 'case2)
               (999999999999999 'case3)
               (3.4 'case4)
               (else 'oops)))])
    (and (eq? (f (string-ref "abc" 0)) 'case1)
         (eq? (f (exact 0.5)) 'case2)
         (eq? (f (- 1000000000000000 1)) 'case3)
         (eq? (f (+ 3.0 4/10)) 'case4)
         (eq? (f 'b) 'oops)))
  (case '() [() #f] [else #t])
  (case '() [(()) #t] [else #f])
  (case "meow" ["meow" #t] [else #f])
  (case '(1 2 3) [((1 2 3) (3 2 1)) #t] [else #f])
  (case 'a [1 6] ["meow" #f] [(a b c) #t])
  (case #\: [1 6] ["meow" #f] [(a b c) #f] [(#\; #\9 #\: #\4) #t])
  (case (/ 12.0 3.0) [(4 5 6) #f] [("bla") #f] [(a b c) #f] [(1 5.8 4.9 4.0) #t] [else #f])
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(define foo
             (lambda (x)
               (case x
                 [("three" 4) 'B]
                 [("three" 5) 'A]
                 [else #f]))))
        (pretty-print
          '(begin
             (do ([i 10 (fx- i 1)]) ((fx= i 0)) (write (foo 5)))
             (write (foo "three")))))
      'replace)
    (profile-clear-database)
    #t)
  ; verify no reordering w/no profile information
  (let ([x (let* ([ip (open-file-input-port "testfile.ss")]
                  [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
                  [ip (transcoded-port ip (native-transcoder))])
             (let-values ([(x efp) (get-datum/annotations ip sfd 0)])
               (close-port ip)
               (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))])
    ; redundant keys might or might not be pruned, so allow it both ways
    (or (equivalent-expansion?
          x
          '(begin
             (set! foo
               (lambda (x)
                 (let ([t x])
                   (if (#2%member t '("three" 4))
                       'B
                       (if (#2%member t '("three" 5))
                           'A
                           #f)))))
             (#2%void)))
        (equivalent-expansion?
          x
          '(begin
             (set! foo
               (lambda (x)
                 (let ([t x])
                   (if (#2%member t '("three" 4))
                       'B
                       (if (#2%member t '(5))
                           'A
                           #f)))))
             (#2%void)))))
  (equal?
    (with-output-to-string
      (lambda ()
        (parameterize ([compile-profile #t]) (load "testfile.ss" compile))))
    "AAAAAAAAAAB")
  (begin
    (profile-dump-data "testfile.pd" (remp preexisting-profile-dump-entry? (profile-dump)))
    (profile-load-data "testfile.pd")
    #t)
  (equal?
    (with-output-to-string
      (lambda ()
        (load "testfile.ss" compile)))
    "AAAAAAAAAAB")
  ; verify reordering based on profile information
  (equivalent-expansion?
    (let* ([ip (open-file-input-port "testfile.ss")]
           [sfd (make-source-file-descriptor "testfile.ss" ip #t)]
           [ip (transcoded-port ip (native-transcoder))])
      (let-values ([(x efp) (get-datum/annotations ip sfd 0)])
        (close-port ip)
        (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f]) (expand/optimize x))))
    '(begin
       (set! foo
         (lambda (x)
           (let ([t x])
             (if (#2%member t '(5))
                 'A
                 (if (#2%member t '("three" 4))
                     'B
                     #f)))))
       (#2%void)))
  (begin
    (profile-clear-database)
    #t)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
      (expand/optimize '(lambda (x) (case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
    '(lambda (x)
       (let ([t x])
         (if (#2%member t '(a b 7))
             'one
             (if (#2%member t '(c 9))
                 'two
                 'three)))))
  ; ensure we don't miss syntax errors through case discarding unreachable clause bodies
  (error? ; invalid syntax (if)
    (lambda (x)
      (case x
        [(a) 'one]
        [(b c) 'two]
        [(a b c) (if)]
        [else #f])))
  ; ensure expansion into cond doesn't cause => to "work" for case
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) #f]
        [(d e f) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) #f]
        [(a b c) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) => values]
        [else #f])))
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) #f]
        [(d e f) => values]
        [else #f])))
  (error? ; invalid syntax =>
    (lambda (x)
      (case x
        [(a b c) #f]
        [(a b c) => values]
        [else #f])))
  (error? ; invalid syntax (case)
    (case))
)

(mat r6rs:case
  (error? ; invalid syntax
    (let ()
      (import (only (rnrs) case))
      (case 'a [a 'yes] [b 'no])))
  (error? ; invalid syntax
    (let ()
      (import (only (rnrs) case))
      (case 'a [a 'yes] [b 'no])))
  (let ((a 'a))
    (import (only (rnrs) case))
    (and
      (begin (set! a 'a)
        (case a ((a) #t) ((b c) #f))
        (case a ((a) #t) ((b c) #f) (else #f)))
      (begin (set! a 'b)
        (case a ((a) #f) ((b c) #t))
        (case a ((a) #f) ((b c) #t) (else #f)))
      (begin (set! a 'c)
        (case a ((a) #f) ((b c) #t))
        (case a ((a) #f) ((b c) #t) (else #f)))
      (begin (set! a 'd)
        (case a ((a) #f) ((b c) #f) (else #t)))))
  (let ([f (lambda (x)
             (import (only (rnrs) case))
             (case x
               ((#\a) 'case1)
               ((1/2) 'case2)
               ((999999999999999) 'case3)
               ((3.4) 'case4)
               (else 'oops)))])
    (and (eq? (f (string-ref "abc" 0)) 'case1)
         (eq? (f (exact 0.5)) 'case2)
         (eq? (f (- 1000000000000000 1)) 'case3)
         (eq? (f (+ 3.0 4/10)) 'case4)
         (eq? (f 'b) 'oops)))
  (let ()
    (import (only (rnrs) case))
    (case '() [() #f] [else #t]))
  (let ()
    (import (only (rnrs) case))
    (case '() [(()) #t] [else #f]))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #f] [#%$suppress-primitive-inlining #f])
      (expand/optimize '(lambda (x)
                          (import (only (rnrs) case))
                          (case x [(a b a 7) 'one] [(c a 7 9) 'two] [else 'three]))))
    '(lambda (x)
       (let ([t x])
         (if (#2%memv t '(a b 7))
             'one
             (if (#2%memv t '(c 9))
                 'two
                 'three)))))
  ; ensure we don't miss syntax errors through case discarding unreachable clause bodies
  (error? ; invalid syntax (if)
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a) 'one]
        [(b c) 'two]
        [(a b c) (if)]
        [else #f])))
  ; ensure expansion into cond doesn't cause => to "work" for case
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) #f]
        [(d e f) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) #f]
        [(a b c) => values])))
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) => values]
        [else #f])))
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) #f]
        [(d e f) => values]
        [else #f])))
  (error? ; invalid syntax =>
    (lambda (x)
      (import (only (rnrs) case))
      (case x
        [(a b c) #f]
        [(a b c) => values]
        [else #f])))
  (error? ; invalid syntax (case)
    (let ()
      (import (only (rnrs) case))
      (case)))
)

(mat record-case
   (record-case '(a b c)
      [a (b c) (and (eq? b 'b) (eq? c 'c))]
      [b x #f]
      [c x #f]
      [else #f])
   (record-case (list #\a #\b #\c)
      [#\a (b c) (and (eq? b #\b) (eq? c #\c))]
      [#\b x #f]
      [#\c x #f])
   (record-case (list (/ 3 4) 'b 'c)
      [1/2 x #f]
      [3/4 x (equal? x '(b c))]
      [5/8 x #f]
      [else #f])
   (record-case '(d a b c)
      [a x (equal? x '(b c))]
      [b x #f]
      [c x #f]
      [else #t])
   (record-case '(a b c d e)
      [a (x1 x2 x3 . x4) (equal? (list x1 x2 x3 x4) '(b c d (e)))]
      [else #f])
 )

;;; section 4-5:

(mat named-let
   (eqv? (let f ((x 5)) (if (zero? x) 1 (* x (f (1- x))))) 120)
   (let f ((x 10000)) (if (zero? x) #t (f (1- x))))
   (let f ([x 10] [y 0]) (or (and (= x 0) (= y 10)) (f (- x 1) (+ y 1))))
   (eqv? (let f ([x 10]) (if (= x 0) 1 (+ (f (- x 1)) 1))) 11)
   (eqv? (let ([base 20])
            (let f ([x 10])
               (if (= x 0) base
                   (+ (f (- x 1)) 1))))
         30)
   ; this looks almost like a named let, but isn't, and is treated as
   ; if the 4 were not present by some earlier verisons
   (error? ((letrec ((x (lambda (x) x))) x) 3 4))
 )

(define ($destroy ls x)
  (when (pair? ls)
    ($destroy (cdr ls) x)
    (set-cdr! ls x)))

(mat map
   (eqv? (map car '()) '())
   (equal? (map 1+ '(1 2 3 4 5 6)) '(2 3 4 5 6 7))
   (equal? (map 1+ '()) '())
   (equal? (map cons '(1 2 3) '(4 5 6)) '((1 . 4) (2 . 5) (3 . 6)))
   (let ((x 3))
      (equal? (apply + (map (lambda (y) (set! x (1+ x)) x) '(a b c d)))
              22))
   (equal? (map (lambda (x y z) (+ x (+ y z)))
                '(1 2 3 4 5)
                '(11 12 13 14 15)
                '(21 22 23 24 25))
           '(33 36 39 42 45))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '())
         (map p '() x1)
         (map p '() x1 x2)
         (map p '() x1 x2 x3)
         (map p '() x1 x2 x3 x4)
         (map p '() x1 x2 x3 x4 x5)
         (map p x1 '())
         (map p x1 '() x2)
         (map p x1 '() x2 x3)
         (map p x1 '() x2 x3 x4)
         (map p x1 '() x2 x3 x4 x5)
         (map p x1 x2 '())
         (map p x1 x2 '() x3)
         (map p x1 x2 '() x3 x4)
         (map p x1 x2 '() x3 x4 x5)
         (map p x1 x2 x3 '())
         (map p x1 x2 x3 '() x4)
         (map p x1 x2 x3 '() x4 x5)
         (map p x1 x2 x3 x4 '())
         (map p x1 x2 x3 x4 '() x5)
         (map p x1 x2 x3 x4 x5 '())))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '() '() '() '() '())
     '(() () () () () () () () () () () () () () () () () ()
       () () ()))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '(a))
         (map p '(a) x1)
         (map p '(a) x1 x2)
         (map p '(a) x1 x2 x3)
         (map p '(a) x1 x2 x3 x4)
         (map p '(a) x1 x2 x3 x4 x5)
         (map p x1 '(a))
         (map p x1 '(a) x2)
         (map p x1 '(a) x2 x3)
         (map p x1 '(a) x2 x3 x4)
         (map p x1 '(a) x2 x3 x4 x5)
         (map p x1 x2 '(a))
         (map p x1 x2 '(a) x3)
         (map p x1 x2 '(a) x3 x4)
         (map p x1 x2 '(a) x3 x4 x5)
         (map p x1 x2 x3 '(a))
         (map p x1 x2 x3 '(a) x4)
         (map p x1 x2 x3 '(a) x4 x5)
         (map p x1 x2 x3 x4 '(a))
         (map p x1 x2 x3 x4 '(a) x5)
         (map p x1 x2 x3 x4 x5 '(a))))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '(1) '(4) '(d) '(g) '(7))
     '(((a))
       ((a 1))
       ((a 1 4))
       ((a 1 4 d))
       ((a 1 4 d g))
       ((a 1 4 d g 7))
       ((1 a))
       ((1 a 4))
       ((1 a 4 d))
       ((1 a 4 d g))
       ((1 a 4 d g 7))
       ((1 4 a))
       ((1 4 a d))
       ((1 4 a d g))
       ((1 4 a d g 7))
       ((1 4 d a))
       ((1 4 d a g))
       ((1 4 d a g 7))
       ((1 4 d g a))
       ((1 4 d g a 7))
       ((1 4 d g 7 a))))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '(a b))
         (map p '(a b) x1)
         (map p '(a b) x1 x2)
         (map p '(a b) x1 x2 x3)
         (map p '(a b) x1 x2 x3 x4)
         (map p '(a b) x1 x2 x3 x4 x5)
         (map p x1 '(a b))
         (map p x1 '(a b) x2)
         (map p x1 '(a b) x2 x3)
         (map p x1 '(a b) x2 x3 x4)
         (map p x1 '(a b) x2 x3 x4 x5)
         (map p x1 x2 '(a b))
         (map p x1 x2 '(a b) x3)
         (map p x1 x2 '(a b) x3 x4)
         (map p x1 x2 '(a b) x3 x4 x5)
         (map p x1 x2 x3 '(a b))
         (map p x1 x2 x3 '(a b) x4)
         (map p x1 x2 x3 '(a b) x4 x5)
         (map p x1 x2 x3 x4 '(a b))
         (map p x1 x2 x3 x4 '(a b) x5)
         (map p x1 x2 x3 x4 x5 '(a b))))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '(1 2) '(4 5) '(d e) '(g h) '(7 j))
     '(((a) (b))
       ((a 1) (b 2))
       ((a 1 4) (b 2 5))
       ((a 1 4 d) (b 2 5 e))
       ((a 1 4 d g) (b 2 5 e h))
       ((a 1 4 d g 7) (b 2 5 e h j))
       ((1 a) (2 b))
       ((1 a 4) (2 b 5))
       ((1 a 4 d) (2 b 5 e))
       ((1 a 4 d g) (2 b 5 e h))
       ((1 a 4 d g 7) (2 b 5 e h j))
       ((1 4 a) (2 5 b))
       ((1 4 a d) (2 5 b e))
       ((1 4 a d g) (2 5 b e h))
       ((1 4 a d g 7) (2 5 b e h j))
       ((1 4 d a) (2 5 e b))
       ((1 4 d a g) (2 5 e b h))
       ((1 4 d a g 7) (2 5 e b h j))
       ((1 4 d g a) (2 5 e h b))
       ((1 4 d g a 7) (2 5 e h b j))
       ((1 4 d g 7 a) (2 5 e h j b))))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '(a b c))
         (map p '(a b c) x1)
         (map p '(a b c) x1 x2)
         (map p '(a b c) x1 x2 x3)
         (map p '(a b c) x1 x2 x3 x4)
         (map p '(a b c) x1 x2 x3 x4 x5)
         (map p x1 '(a b c))
         (map p x1 '(a b c) x2)
         (map p x1 '(a b c) x2 x3)
         (map p x1 '(a b c) x2 x3 x4)
         (map p x1 '(a b c) x2 x3 x4 x5)
         (map p x1 x2 '(a b c))
         (map p x1 x2 '(a b c) x3)
         (map p x1 x2 '(a b c) x3 x4)
         (map p x1 x2 '(a b c) x3 x4 x5)
         (map p x1 x2 x3 '(a b c))
         (map p x1 x2 x3 '(a b c) x4)
         (map p x1 x2 x3 '(a b c) x4 x5)
         (map p x1 x2 x3 x4 '(a b c))
         (map p x1 x2 x3 x4 '(a b c) x5)
         (map p x1 x2 x3 x4 x5 '(a b c))))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '(1 2 3) '(4 5 6) '(d e f) '(g h i) '(7 j 9))
     '(((a) (b) (c))
       ((a 1) (b 2) (c 3))
       ((a 1 4) (b 2 5) (c 3 6))
       ((a 1 4 d) (b 2 5 e) (c 3 6 f))
       ((a 1 4 d g) (b 2 5 e h) (c 3 6 f i))
       ((a 1 4 d g 7) (b 2 5 e h j) (c 3 6 f i 9))
       ((1 a) (2 b) (3 c))
       ((1 a 4) (2 b 5) (3 c 6))
       ((1 a 4 d) (2 b 5 e) (3 c 6 f))
       ((1 a 4 d g) (2 b 5 e h) (3 c 6 f i))
       ((1 a 4 d g 7) (2 b 5 e h j) (3 c 6 f i 9))
       ((1 4 a) (2 5 b) (3 6 c))
       ((1 4 a d) (2 5 b e) (3 6 c f))
       ((1 4 a d g) (2 5 b e h) (3 6 c f i))
       ((1 4 a d g 7) (2 5 b e h j) (3 6 c f i 9))
       ((1 4 d a) (2 5 e b) (3 6 f c))
       ((1 4 d a g) (2 5 e b h) (3 6 f c i))
       ((1 4 d a g 7) (2 5 e b h j) (3 6 f c i 9))
       ((1 4 d g a) (2 5 e h b) (3 6 f i c))
       ((1 4 d g a 7) (2 5 e h b j) (3 6 f i c 9))
       ((1 4 d g 7 a) (2 5 e h j b) (3 6 f i 9 c))))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '(a b c d))
         (map p '(a b c d) x1)
         (map p '(a b c d) x1 x2)
         (map p '(a b c d) x1 x2 x3)
         (map p '(a b c d) x1 x2 x3 x4)
         (map p '(a b c d) x1 x2 x3 x4 x5)
         (map p x1 '(a b c d))
         (map p x1 '(a b c d) x2)
         (map p x1 '(a b c d) x2 x3)
         (map p x1 '(a b c d) x2 x3 x4)
         (map p x1 '(a b c d) x2 x3 x4 x5)
         (map p x1 x2 '(a b c d))
         (map p x1 x2 '(a b c d) x3)
         (map p x1 x2 '(a b c d) x3 x4)
         (map p x1 x2 '(a b c d) x3 x4 x5)
         (map p x1 x2 x3 '(a b c d))
         (map p x1 x2 x3 '(a b c d) x4)
         (map p x1 x2 x3 '(a b c d) x4 x5)
         (map p x1 x2 x3 x4 '(a b c d))
         (map p x1 x2 x3 x4 '(a b c d) x5)
         (map p x1 x2 x3 x4 x5 '(a b c d))))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '(1 2 3 4) '(f g h i) '(k l m n) '(p q r s) '(u v w x))
     '(((a) (b) (c) (d)) ((a 1) (b 2) (c 3) (d 4))
       ((a 1 f) (b 2 g) (c 3 h) (d 4 i))
       ((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n))
       ((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s))
       ((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x))
       ((1 a) (2 b) (3 c) (4 d))
       ((1 a f) (2 b g) (3 c h) (4 d i))
       ((1 a f k) (2 b g l) (3 c h m) (4 d i n))
       ((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s))
       ((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x))
       ((1 f a) (2 g b) (3 h c) (4 i d))
       ((1 f a k) (2 g b l) (3 h c m) (4 i d n))
       ((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s))
       ((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x))
       ((1 f k a) (2 g l b) (3 h m c) (4 i n d))
       ((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s))
       ((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x))
       ((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d))
       ((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x))
       ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d))))
   (begin
     (define ($map-f1 p x1 x2 x3 x4 x5)
       (list
         (map p '(a b c d e))
         (map p '(a b c d e) x1)
         (map p '(a b c d e) x1 x2)
         (map p '(a b c d e) x1 x2 x3)
         (map p '(a b c d e) x1 x2 x3 x4)
         (map p '(a b c d e) x1 x2 x3 x4 x5)
         (map p x1 '(a b c d e))
         (map p x1 '(a b c d e) x2)
         (map p x1 '(a b c d e) x2 x3)
         (map p x1 '(a b c d e) x2 x3 x4)
         (map p x1 '(a b c d e) x2 x3 x4 x5)
         (map p x1 x2 '(a b c d e))
         (map p x1 x2 '(a b c d e) x3)
         (map p x1 x2 '(a b c d e) x3 x4)
         (map p x1 x2 '(a b c d e) x3 x4 x5)
         (map p x1 x2 x3 '(a b c d e))
         (map p x1 x2 x3 '(a b c d e) x4)
         (map p x1 x2 x3 '(a b c d e) x4 x5)
         (map p x1 x2 x3 x4 '(a b c d e))
         (map p x1 x2 x3 x4 '(a b c d e) x5)
         (map p x1 x2 x3 x4 x5 '(a b c d e))))
     (procedure? $map-f1))
   (equal?
     ($map-f1 list '(1 2 3 4 5) '(f g h i j) '(k l m n o) '(p q r s t) '(u v w x y))
     '(((a) (b) (c) (d) (e)) ((a 1) (b 2) (c 3) (d 4) (e 5))
       ((a 1 f) (b 2 g) (c 3 h) (d 4 i) (e 5 j))
       ((a 1 f k) (b 2 g l) (c 3 h m) (d 4 i n) (e 5 j o))
       ((a 1 f k p) (b 2 g l q) (c 3 h m r) (d 4 i n s) (e 5 j o t))
       ((a 1 f k p u) (b 2 g l q v) (c 3 h m r w) (d 4 i n s x) (e 5 j o t y))
       ((1 a) (2 b) (3 c) (4 d) (5 e))
       ((1 a f) (2 b g) (3 c h) (4 d i) (5 e j))
       ((1 a f k) (2 b g l) (3 c h m) (4 d i n) (5 e j o))
       ((1 a f k p) (2 b g l q) (3 c h m r) (4 d i n s) (5 e j o t))
       ((1 a f k p u) (2 b g l q v) (3 c h m r w) (4 d i n s x) (5 e j o t y))
       ((1 f a) (2 g b) (3 h c) (4 i d) (5 j e))
       ((1 f a k) (2 g b l) (3 h c m) (4 i d n) (5 j e o))
       ((1 f a k p) (2 g b l q) (3 h c m r) (4 i d n s) (5 j e o t))
       ((1 f a k p u) (2 g b l q v) (3 h c m r w) (4 i d n s x) (5 j e o t y))
       ((1 f k a) (2 g l b) (3 h m c) (4 i n d) (5 j o e))
       ((1 f k a p) (2 g l b q) (3 h m c r) (4 i n d s) (5 j o e t))
       ((1 f k a p u) (2 g l b q v) (3 h m c r w) (4 i n d s x) (5 j o e t y))
       ((1 f k p a) (2 g l q b) (3 h m r c) (4 i n s d) (5 j o t e))
       ((1 f k p a u) (2 g l q b v) (3 h m r c w) (4 i n s d x) (5 j o t e y))
       ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e))))
 ; make sure compiler doesn't bomb w/two few args
  (procedure? (lambda (x) (map x)))
  (error? ; nonprocedure
    (map 3 '()))
  (error? ; nonprocedure
    (map 3 '() '()))
  (error? ; nonprocedure
    (map 3 '(a b c)))
  (error? ; nonprocedure
    (parameterize ([optimize-level 3])
      (eval '(#2%map 3 '(a b c)))))
  (error? ; nonprocedure
    (parameterize ([optimize-level 3])
      (eval
        '(let ()
           (define (f p b)
             (unbox b)
             (#2%map p (if (box? b) '() '(1 2 3)))
             (list p (procedure? p)))
           (f 7 (box 0))))))
  (error? ; improper list
    (map pretty-print 'a))
  (error? ; improper list
    (map pretty-print '(a . b)))
  (error? ; cyclic list
    (map pretty-print '#1=(a . #1#)))
  (error? ; length mismatch
    (map list '(a b) '(p q r)))
  (error? ; length mismatch
    (map list '(1 2) '(a b) '(p q r)))
  (error? ; improper list
    (map list 'a '(a b)))
  (error? ; improper list
    (map list '(a b) 'a))
  (error? ; improper list
    (map list '(a . b) '(a b)))
  (error? ; improper list
    (map list '(a b) '(a . b)))
  (error? ; cyclic list
    (map list '#1# '(a b c)))
  (error? ; cyclic list
    (map list '(a b c) '#1#))
  (error? ; improper list
    (map list 'a '(a b) '(1 2)))
  (error? ; improper list
    (map list '(a b) 'a '(1 2)))
  (error? ; improper list
    (map list '(a b) '(1 2) 'a))
  (error? ; improper list
    (map list '(a . b) '(a b) '(1 2)))
  (error? ; improper list
    (map list '(a b) '(a . b) '(1 2)))
  (error? ; improper list
    (map list '(a b) '(1 2) '(a . b)))
  (error? ; cyclic list
    (map list '#1# '(a b c) '(1 2 3)))
  (error? ; cyclic list
    (map list '(a b c) '#1# '(1 2 3)))
  (error? ; cyclic list
    (map list '(a b c) '(1 2 3) '#1#))
  (equal?
    (let ((l (list 1 2 3 4)))
      (map (lambda (x) ($destroy l 1) (* x x)) l))
    '(1 4 9 16))
  (equal?
    (let ((l (list 1 2 3 4)))
      (map (lambda (x y) ($destroy l y) (cons x y)) l '(a b c d)))
    '((1 . a) (2 . b) (3 . c) (4 . d)))
  (equal?
    (let ((l (list 1 2 3 4)))
      (map (lambda (x y) ($destroy l '()) (cons x y)) l '(a b c d)))
    '((1 . a) (2 . b) (3 . c) (4 . d)))
  (equal?
    (let ((l (list 1 2 3 4)))
      (map (lambda (x y) ($destroy l y) (cons x y)) '(a b c d) l))
    '((a . 1) (b . 2) (c . 3) (d . 4)))
  (equal?
    (let ((l (list 1 2 3 4 5 6 7)))
      (map (lambda (x y z) ($destroy l '()) (list z x y))
           l
           '(a b c d e f g)
           '(p q r s t u v)))
    '((p 1 a) (q 2 b) (r 3 c) (s 4 d) (t 5 e) (u 6 f) (v 7 g)))
  (equal?
    (let ((l (list 1 2 3 4 5 6 7)))
      (map (lambda (x y z) ($destroy l '()) (list z x y))
           '(a b c d e f g)
           l
           '(p q r s t u v)))
    '((p a 1) (q b 2) (r c 3) (s d 4) (t e 5) (u f 6) (v g 7)))
  (equal?
    (let ((l (list 1 2 3 4 5 6 7)))
      (map (lambda (x y z) ($destroy l '()) (list z x y))
           '(a b c d e f g)
           '(p q r s t u v)
           l))
    '((1 a p) (2 b q) (3 c r) (4 d s) (5 e t) (6 f u) (7 g v)))
  (let ([orig-ls #f] [orig-cars #f] [orig-cdrs #f] [next #f])
    (define (copy-spine ls)
      (if (null? ls)
          '()
          (cons ls (copy-spine (cdr ls)))))
    (let ([n 100])
      (let ([ls (map (lambda (x) (cons (call/cc values) x)) (iota n))])
        (if orig-ls
            (begin
              (unless (andmap eq? orig-ls orig-cars)
                (errorf #f "original map cars mutated"))
              (unless (andmap eq? (copy-spine orig-ls) orig-cdrs)
                (errorf #f "original map cdrs mutated")))
            (begin
              (set! orig-ls ls)
              (set! orig-cars (list-copy ls))
              (set! orig-cdrs (copy-spine ls))
              (set! next 0)))
        (let ([m next])
          (unless (= m n)
            (set! next (fx+ next 1)) 
            (let ([p (list-ref orig-ls m)])
              (unless (eqv? (cdr p) m)
                (errorf #f "unexpected cdr value (~s instead of ~s)" (cdr p) m))
              ((car p) n)))))
      (eqv? next n)))
  (equal?
    (let ([x 3])
      (let ([y (map (begin (set! x 14) cons) '())])
        (list x y)))
    '(14 ()))
  (equal?
    (let ([x 3])
      (let ([y (map (begin (set! x 14) list) '() '() '())])
        (list x y)))
    '(14 ()))
  ;; cp0 optimizations for map
  ;; mapping over empty list(s) always returns '()
  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
    (test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
  (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
    (test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
    (test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
  (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
    (test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
  ;; if map is called only for effects, remove the expression only if the procedure
  ;; has the correct arity and can't raise an error
  (equivalent-expansion?
    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
      (expand/optimize
        '(begin (#3%map list '(5 4 3 2 1 0)) 7)))
    7)
  (equivalent-expansion?
    (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
      (expand/optimize
        '(begin (#3%map box? '(5 4 3 2 1 0)) 7)))
    7)
  (not (equivalent-expansion?
         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
           (expand/optimize
             '(begin (#3%map unbox '(5 4 3 2 1 0)) 7)))
           7))
  (not (equivalent-expansion?
         (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
           (expand/optimize
             '(begin (#3%map cons '(5 4 3 2 1 0)) 7)))
           7))
  ;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
  ;; avoid creating each list and doing the actual map
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           (list 1 2 3)
           (list 4 5 6)
           (list '(7) '(8) '(9)))))
    '(#2%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           (list 1 2 3)
           (list 4 5 6)
           (list '(7) '(8) '(9)))))
    '(#3%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           '(1 2 3)
           (list 4 5 6)
           (list '(7) '(8) '(9)))))
    '(#2%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           '(1 2 3)
           (list 4 5 6)
           (list '(7) '(8) '(9)))))
    '(#3%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           '(1 2 3)
           '(4 5 6)
           '((7) (8) (9)))))
    '(#2%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize 
        '(map (lambda (x y z) (apply + x y z)) 
           '(1 2 3)
           '(4 5 6)
           '((7) (8) (9)))))
    '(#3%list 12 15 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(map (lambda (x y z)
                (string->symbol
                  (apply
                    string-append
                    (map symbol->string (list x y z)))))
              (list 'a 't 'x)
              (list 'b 'u 'y)
              (list 'c 'v 'z))))
    '(#2%list
       (#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"))))
  (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")
 )

(mat continuation-attachments
  (error? (#%$current-continuation-attachments '()))

  (error? (#%$call-setting-continuation-attachment 'any))
  (error? (#%$call-setting-continuation-attachment 'any 10))
  (error? (#%$call-setting-continuation-attachment 'any void 'bad-more))
  (error? (#%$call-setting-continuation-attachment 'any (lambda (x) x)))

  (error? (#%$call-getting-continuation-attachment 'none))
  (error? (#%$call-getting-continuation-attachment 'none 10))
  (error? (#%$call-getting-continuation-attachment 'none (lambda (a) a) 'bad-more))
  (error? (#%$call-getting-continuation-attachment 'none void))

  (error? (#%$call-consuming-continuation-attachment 'none))
  (error? (#%$call-consuming-continuation-attachment 'none 10))
  (error? (#%$call-consuming-continuation-attachment 'none (lambda (a) a) 'bad-more))
  (error? (#%$call-consuming-continuation-attachment 'none void))

  (error? (#%$continuation-next-attachments))
  (error? (#%$continuation-next-attachments 10))
  (error? (#%$continuation-next-attachments (lambda (x) x)))
  (error? (#%$continuation-next-attachments (call/cc (lambda (x) x)) 'bad-more))

  (equal? (void) (#%$call-setting-continuation-attachment 'any void))
  (equal? 'none (#%$call-getting-continuation-attachment 'none (lambda (a) a)))
  (equal? 'none (#%$call-consuming-continuation-attachment 'none (lambda (a) a)))
  (equal? '() (#%$continuation-attachments (call/cc (lambda (x) x))))

  (equal? '() (#%$current-attachments))
  (equal? '(#&(1 2 3))
          (#%$call-setting-continuation-attachment
           3
           (lambda ()
            (list
             (#%$call-setting-continuation-attachment
              2
              (lambda ()
               (box
                (#%$call-setting-continuation-attachment
                 1
                 (lambda ()
                   (#%$current-attachments))))))))))
  (equal? '() (#%$current-attachments))
  (equal? '#((left) (right))
          (vector (#%$call-setting-continuation-attachment
                   'left
                   (lambda () (#%$current-attachments)))
                  (#%$call-setting-continuation-attachment
                   'right
                   (lambda () (#%$current-attachments)))))
  (equal? '#((left2) (right2))
          (vector (#%$call-setting-continuation-attachment
                   'left2
                   #%$current-attachments)
                  (#%$call-setting-continuation-attachment
                   'right2
                   #%$current-attachments)))
  (equal? 'yes
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (#%$call-getting-continuation-attachment
             'no
             (lambda (v) v)))))
  (equal? 'yes
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (#%$call-consuming-continuation-attachment
             'no
             (lambda (v) v)))))
  (equal? 'yes
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (#%$call-getting-continuation-attachment
             'no
             values))))
  (equal? 'yes
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (#%$call-consuming-continuation-attachment
             'no
             values))))
  (equal? '(no)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (list
             (#%$call-getting-continuation-attachment
              'no
              (lambda (v) v))))))
  (equal? '(no)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (list
             (#%$call-consuming-continuation-attachment
              'no
              (lambda (v) v))))))
  (equal? '(no)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (list
             (#%$call-getting-continuation-attachment
              'no
              values)))))
  (equal? '(no)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
            (list
             (#%$call-consuming-continuation-attachment
              'no
              values)))))
  (equal? '(yes yes)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
             (#%$call-getting-continuation-attachment
              'no
              (lambda (a)
                (#%$call-getting-continuation-attachment
                'no
                 (lambda (b)
                   (list a b))))))))
  (equal? '(yes no)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
             (#%$call-consuming-continuation-attachment
              'no
              (lambda (a)
                (#%$call-consuming-continuation-attachment
                'no
                 (lambda (b)
                   (list a b))))))))
  (equal? '(yes again)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
             (#%$call-getting-continuation-attachment
              'no
              (lambda (a)
                (#%$call-setting-continuation-attachment
                 'again
                 (lambda ()
                   (#%$call-getting-continuation-attachment
                    'no
                    (lambda (b)
                      (list a b))))))))))
  (equal? '(yes again)
          (#%$call-setting-continuation-attachment
           'yes
           (lambda ()
             (#%$call-consuming-continuation-attachment
              'no
              (lambda (a)
                (#%$call-setting-continuation-attachment
                 'again
                 (lambda ()
                   (#%$call-consuming-continuation-attachment
                    'no
                    (lambda (b)
                      (list a b))))))))))
  (equal? '(no again)
          (#%$call-consuming-continuation-attachment
           'no
           (lambda (a)
             (#%$call-setting-continuation-attachment
              'again
              (lambda ()
                (#%$call-consuming-continuation-attachment
                 'no
                 (lambda (b)
                   (list a b))))))))
  (begin
   (define (call-with-yep f)
     (#%$call-setting-continuation-attachment
      'yep
       (lambda () (f))))
   (define (call-with-yeah f)
     (#%$call-setting-continuation-attachment
      'yeah
       f))
   (define (call-with-nothing f)
     (#%$value
      (f)))
   (define (call-with-nothing-in-split f)
     ((call/cc
       (lambda (k)
         (#%$split-continuation k 0)
         f))))
   (define-syntax call-with-yeah*
     (syntax-rules ()
       [(_ f)
        (#%$call-setting-continuation-attachment
         'yeah
         f)]))
   (define (get-or-nope)
     (#%$call-getting-continuation-attachment
      'nope
      (lambda (x) x)))
   (define (consume-or-nope)
     (#%$call-consuming-continuation-attachment
      'nope
      (lambda (x) x)))
   (define (consume-or-nope-cps k)
     (lambda ()
       (#%$call-consuming-continuation-attachment
        'nope
        (lambda (x) (k x)))))
   (define (return-one) 1)
   (define (act-like-list . l) l)
   (define not-a-procedure 'something-else)
   (define (returns-not-a-procedure) 'also-something-else)
   (define (return-three-values) (values 1 2 3))
   (define (return-the-same-value v) v)
   (define (check-attachments-start v r)
     (let ([ats (#%$current-attachments)])
       (and (pair? ats)
            (equal? (car ats) v)
            r)))
   (define (callcc-after-attachment proc)
     (#%$call-setting-continuation-attachment
      'attach
      (lambda ()
        ;; Expect this `call/cc` to be inlined, but most promote
        ;; the continuation created by `#%$call-setting-continuation-attachment`
        (call/cc
         (lambda (k)
           (proc k))))))
   #t)
  (equal? 'yep (call-with-yep get-or-nope))
  (equal? 'yep (call-with-yep consume-or-nope))
  (equal? 'yeah (call-with-yep (lambda () (call-with-yeah get-or-nope))))
  (equal? '(yeah) (call-with-yep (lambda () (call-with-yeah #%$current-attachments))))
  (equal? '((yeah yep)) (call-with-yep (lambda () (list (call-with-yeah #%$current-attachments)))))
  (equal? '((yeah yep)) (call-with-yep (lambda () (act-like-list (call-with-yeah #%$current-attachments)))))
  (equal? '(yeah yep) (call-with-yep (lambda () (let ([v #f])
                                                  (set! v (call-with-yeah #%$current-attachments))
                                                  v))))
  (equal? '(nope) (call-with-yep (lambda () (list (get-or-nope)))))
  (equal? '(nope) (call-with-yep (lambda () (act-like-list (get-or-nope)))))
  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (list (get-or-nope)))))))
  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah (lambda () (act-like-list (get-or-nope)))))))
  (equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah (lambda () (get-or-nope)))))))
  (equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah (lambda () (get-or-nope)))))))
  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (list (get-or-nope)))))))
  (equal? '(nope) (call-with-yep (lambda () (call-with-yeah* (lambda () (act-like-list (get-or-nope)))))))
  (equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah* (lambda () (get-or-nope)))))))
  (equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (get-or-nope)))))))

  (equal? 'nope (call-with-yep (consume-or-nope-cps
                                (lambda (v)
                                  (get-or-nope)))))

  (error? (call-with-yep (lambda () (call-with-yeah* (lambda () (not-a-procedure))))))
  (error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () (not-a-procedure)))))))
  (error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (not-a-procedure)))))))
  (error? (call-with-yep (lambda () (call-with-yeah* (lambda () ((returns-not-a-procedure)))))))
  (error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
  (error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () ((returns-not-a-procedure))))))))
  
  (equal? '() (if (call-with-yep list)
                  (#%$current-attachments)
                  #f))
  (equal? '() (if (#%$call-setting-continuation-attachment 'here (lambda () #t))
                  (#%$current-attachments)
                  #f))
  (equal? 1 (let loop ([i 10000])
              (if (zero? i)
                  (length (#%$current-attachments))
                  (#%$call-setting-continuation-attachment
                   'here
                   (lambda ()
                     (loop (sub1 i)))))))
  (equal? 10000 (let loop ([i 10000])
                  (if (zero? i)
                      (length (#%$current-attachments))
                      (#%$call-setting-continuation-attachment
                       'here
                       (lambda ()
                         (return-the-same-value (loop (sub1 i))))))))
  (equal? '#((forget-me yeah yep) (yeah yep))
          (call/cc
           (lambda (esc)
             (call-with-yep
              (lambda ()
                (list (call-with-yeah
                       (lambda ()
                         (list (#%$call-setting-continuation-attachment
                                'forget-me
                                (lambda ()
                                  (call/cc
                                   (lambda (k)
                                     (esc (vector
                                           (#%$current-attachments)
                                           (#%$continuation-attachments k))))))))))))))))
  (equal? '#(((yep) (yep))
             ((yeah yep))
             ((yep) (yep)))
          (let ([pre '()]
                [body '()]
                [post '()])
            ((call/cc
              (lambda (esc)
                (call-with-yep
                 (lambda ()
                   (dynamic-wind
                       (lambda ()
                         (set! pre (cons (#%$current-attachments) pre)))
                       (lambda ()
                         (call-with-yeah
                          (lambda ()
                            ((call/cc
                              (lambda (retry)
                                (set! body (cons (#%$current-attachments) body))
                                (esc retry)))))))
                       (lambda ()
                         (set! post (cons (#%$current-attachments) post))))))))
             (lambda () (lambda (self) void)))
            (vector pre body post)))

  (equal? 'ok
          (#%$call-setting-continuation-attachment
           'ok
           (lambda ()
             (call-with-values (lambda () (return-three-values))
               (case-lambda
                [(x y z)
                 (get-or-nope)])))))
  (equal? '(ok 1 2 3)
          (#%$call-setting-continuation-attachment
           'ok
           (lambda ()
             (call-with-values (lambda () (return-three-values))
               (case-lambda
                [(x y z)
                 (#%$call-getting-continuation-attachment
                  'nope
                  (lambda (a) (list a x y z)))])))))

  ;; intended to trigger `mvcall` in the `#%$np-recognize-attachment` pass:
  (equal? '(1)
          (#%$call-setting-continuation-attachment
           'ok
           (lambda ()
             (call-with-values (lambda () (return-one)) act-like-list))))
  (equal? '(1)
          (letrec ([act-like-list (lambda l
                                    (if (equal? l '(never))
                                        (act-like-list (cdr l))
                                        l))])
            (#%$call-setting-continuation-attachment
             'ok
             (lambda ()
               ;; `call-with-values` can see that `act-like-list` has
               ;; a rest argument, and it generates a direct call
               (call-with-values (lambda () (return-one)) act-like-list)))))
  (equal? '(1)
          ;; Like the previous example, but in tail position
          (call-with-yep ; just to ensure the argument `lambda` isn't inlined
           (lambda ()
             (letrec ([act-like-list (lambda l
                                       (if (equal? l '(never))
                                           (act-like-list (cdr l))
                                           l))])
               (#%$call-setting-continuation-attachment
                'ok
                (lambda ()
                  (call-with-values (lambda () (return-one)) act-like-list)))))))
  (equal? '(1)
          (call-with-yep ; just to ensure the argument `lambda` isn't inlined
           (lambda ()
             (#%$call-setting-continuation-attachment
              'ok
              (lambda ()
                (call-with-values (lambda () (return-one)) act-like-list))))))
  (equal? '(ok)
          (call-with-yep ; just to ensure the argument `lambda` isn't inlined
           (lambda ()
             (#%$call-setting-continuation-attachment
              'ok
              (lambda ()
                ;; Should be detected as a loop form
                (let loop ([i 1000])
                  (if (fx= i 0)
                      (#%$current-attachments)
                      (loop (sub1 i)))))))))
  (equal? 'ok
          (#%$call-setting-continuation-attachment
           -1
           (lambda ()
             (let loop ([i 0])
               (cond
                [(= i 1000) 'ok]
                [else (check-attachments-start
                       (sub1 i)
                       (#%$call-setting-continuation-attachment
                        i
                        (lambda ()
                          ;; Not detected as a loop, but as a direct call
                          (loop (add1 i)))))])))))
  (equal? 'yes
          (call-with-nothing
           (lambda ()
             ;; This "consuming" will need to reify the continuation
             (#%$call-consuming-continuation-attachment
              'no
              (lambda (v)
                (#%$call-setting-continuation-attachment
                 'yes
                 (lambda ()
                   (get-or-nope))))))))
  (equal? 'yes
          (call-with-nothing-in-split
           (lambda ()
             ;; This "consuming" will need to reify the continuation
             (#%$call-consuming-continuation-attachment
              'no
              (lambda (v)
                (#%$call-setting-continuation-attachment
                 'yes
                 (lambda ()
                   (get-or-nope))))))))
  (begin
   (define (gc-and-capture-continuation)
     (collect 0)
     (call/cc
      (lambda (k)
        (lambda ()
          (k (lambda () 8))))))
   (equal? 8
           (let ([v (call/1cc
                     (lambda (ek)
                       (let ([v (#%$call-setting-continuation-attachment
                                 'v
                                 (lambda ()
                                   (gc-and-capture-continuation)))])
                         (if (number? v)
                             (add1 v)
                             v))))])
             (if (procedure? v)
                 (v)
                 'no))))
  (let ([proc (callcc-after-attachment
               (lambda (k)
                 (lambda ()
                   (k (lambda () #t)))))])
    (proc))

  (equal?
   '(2 2)
   (let ([f (parameterize ([run-cp0
                            ;; Disable cp0 inlining of `for-each`:
                            (lambda (cp0 e) e)])
              (eval '(lambda (g l)
                       (let-values ([(x y)
                                     (#%$call-setting-continuation-attachment
                                      'hi
                                      (lambda ()
                                        ;; Could be by `cpnanopoass`, but make
                                        ;; sure it's constrained by the fact that
                                        ;; `for-each` can tail-call `g`:
                                        (#3%for-each g l)))])
                         (list x y)))))])
     (f (lambda (x) (values x x)) (list 1 2))))

 )

(mat continuation-marks
  (error? (continuation-marks-first))
  (error? (continuation-marks-first #f 'x))
  (error? (continuation-marks-first 'oops 'x))
  (error? (continuation-marks-first 'oops 'x 'y))
  (error? (continuation-marks-first (current-continuation-marks) 'x 'y 'z))
  (error? (continuation-marks->list))
  (error? (continuation-marks->list #f))
  (error? (continuation-marks->list 'oops))
  (error? (continuation-marks->list (current-continuation-marks) 'x 'y))
  (error? (continuation-marks->iterator))
  (error? (continuation-marks->iterator #f))
  (error? (continuation-marks->iterator 'oops))
  (error? (continuation-marks->iterator (current-continuation-marks) 'y 'z))
  (error? (continuation-next-marks 'oops))
  (error? (call-with-immediate-continuation-mark #f #f))
  (error? (call-with-immediate-continuation-mark #f #f #f))

  (continuation-marks? (current-continuation-marks))
  (continuation-marks? (continuation-next-marks (call/cc (lambda (k) k))))
  (not (continuation-marks? #f))
  (not (continuation-marks? 'other))

  (equal? 10 (with-continuation-mark 'x 'y 10))
  (equal? 'xv (with-continuation-mark 'x 'xv (continuation-marks-first (current-continuation-marks) 'x)))
  (equal? #f (with-continuation-mark 'x 'xv (continuation-marks-first (current-continuation-marks) 'nonesuch)))
  (equal? 'none (with-continuation-mark 'x 'xv (continuation-marks-first (current-continuation-marks) 'nonesuch 'none)))
  (equal? 'xv (with-continuation-mark 'x 'xv (continuation-marks-first (current-continuation-marks) 'x)))
  (equal? 'xv1 (with-continuation-mark
                   'x 'xv0
                 (with-continuation-mark
                     'x 'xv1
                   (continuation-marks-first (current-continuation-marks) 'x))))
  (equal? '(xv1) (with-continuation-mark
                     'x 'xv0
                   (with-continuation-mark
                       'x 'xv1
                     (continuation-marks->list (current-continuation-marks) 'x))))
  (equal? '((xv1 xv0)) (with-continuation-mark
                           'x 'xv0
                         (list
                          (with-continuation-mark
                              'x 'xv1
                            (continuation-marks->list (current-continuation-marks) 'x)))))

  (equal? '#&xv (with-continuation-mark
                    'x 'xv
                  (call-with-immediate-continuation-mark
                   'x
                   box)))
  (equal? '#&#f (with-continuation-mark
                    'x 'xv
                  (call-with-immediate-continuation-mark
                   'y
                   box)))
  (equal? '#&no-val (with-continuation-mark
                        'x 'xv
                      (call-with-immediate-continuation-mark
                       'y
                       'no-val
                       box)))

  (begin
    (define ($mark-iter->lists iter)
      (let loop ([iter iter])
        (let-values ([(vec iter) (iter)])
          (if vec
              (cons (vector->list vec)
                    (loop iter))
              '()))))
    (define $continuation-marks->lists
      (case-lambda
       [(marks keys) ($mark-iter->lists (continuation-marks->iterator marks (list->vector keys)))]
       [(marks keys no) ($mark-iter->lists (continuation-marks->iterator marks (list->vector keys) no))]))
    #t)
  
  (equal? '((xv1 yv)) (with-continuation-mark
                          'x 'xv0
                        (with-continuation-mark
                            'y 'yv
                          (with-continuation-mark
                              'x 'xv1
                            ($continuation-marks->lists (current-continuation-marks) '(x y))))))
  (equal? '(((xv1 #f) (#f yv))) (with-continuation-mark
                                    'y 'yv
                                  (list
                                   (with-continuation-mark
                                       'x 'xv1
                                     ($continuation-marks->lists (current-continuation-marks) '(x y))))))
  (equal? '(((xv1 no) (no yv))) (with-continuation-mark
                                    'y 'yv
                                  (list
                                   (with-continuation-mark
                                       'x 'xv1
                                     ($continuation-marks->lists (current-continuation-marks) '(x y) 'no)))))
  (equal? '((((xv1 #f) (#f yv)))) (with-continuation-mark
                                      'y 'yv
                                    (list
                                     (list
                                      (with-continuation-mark
                                          'x 'xv1
                                        ($continuation-marks->lists (current-continuation-marks) '(x y)))))))
  (equal? '((((xv1 #f) (xv0 yv)))) (with-continuation-mark
                                       'x 'xv0
                                     (with-continuation-mark
                                         'y 'yv
                                       (list
                                        (with-continuation-mark
                                            'z 'zv
                                          (list
                                           (with-continuation-mark
                                               'x 'xv1
                                             ($continuation-marks->lists (current-continuation-marks) '(x y)))))))))

  (equal? '() (continuation-marks->list
               (continuation-next-marks (with-continuation-mark
                                            'x 'xv
                                          (call/cc (lambda (k) k))))
               'x))

  (equal? '(xv) (continuation-marks->list
                 (continuation-next-marks (car
                                           (with-continuation-mark
                                               'x 'xv
                                             (list
                                              (call/cc (lambda (k) k))))))
                 'x))

  (equal? '42
          (with-continuation-mark 'a 42
            (with-continuation-mark 'b (continuation-marks-first (current-continuation-marks) 'a)
              (continuation-marks-first (current-continuation-marks) 'b))))
  (equal? '42
          (with-continuation-mark 'a 42
            (values
             (with-continuation-mark 'b (continuation-marks-first (current-continuation-marks) 'a)
               (continuation-marks-first (current-continuation-marks) 'b)))))

  (equal? '43
          (with-continuation-mark 'a 'b
            (with-continuation-mark (continuation-marks-first (current-continuation-marks) 'a) 43
              (continuation-marks-first (current-continuation-marks) 'b))))
  (equal? '43
          (with-continuation-mark 'a 'b
            (values
             (with-continuation-mark (continuation-marks-first (current-continuation-marks) 'a) 43
               (continuation-marks-first (current-continuation-marks) 'b)))))

  ;; if this goes quadratic, then it will look like non-termination:
  (with-continuation-mark
      'x 'yes
    (let ([N 100000])
      (let loop ([depth N])
        (if (zero? depth)
            (let loop ([i N])
              (or (zero? i)
                  (and (eq? 'yes (continuation-marks-first (current-continuation-marks) 'x))
                       (eq? 'half (continuation-marks-first (current-continuation-marks) 'half-way))
                       (loop (sub1 i)))))
            (#%$value
             (if (= depth (quotient N 2))
                 (with-continuation-mark
                     'half-way 'half
                   (loop (sub1 depth)))
                 (with-continuation-mark
                     'other 'no
                   (loop (sub1 depth)))))))))
  )

(mat call-in-continuation
  (error? (#%$call-in-continuation 1))
  (error? (#%$call-in-continuation 1 (lambda () 0)))
  (error? (#%$call-in-continuation (lambda args args) (lambda () 0)))
  (error? (call/cc (lambda (k) (#%$call-in-continuation k #f (lambda () 0)))))
  (error? (call/cc (lambda (k) (#%$call-in-continuation k (list 1 2 3) (lambda () 0)))))
  (error? (call-in-continuation 1))
  (error? (call-in-continuation 1 (lambda () 0)))
  (error? (call-in-continuation (lambda args args) (lambda () 0)))
  (error? (call/cc (lambda (k) (call-in-continuation k #f (lambda () 0)))))
  (error? (call/cc (lambda (k) (call-in-continuation k (list 1 2 3) (lambda () 0)))))
  (error? (let ([m (current-continuation-marks)])
            (with-continuation-mark
                'x 'y
              (list
               (call/cc (lambda (k) (call-in-continuation k m (lambda () 0))))))))

  (equal? 10 (+ 1 (call/cc (lambda (k) (#%$call-in-continuation k (lambda () 9))))))
  (equal? 10 (+ 1 (call/cc (lambda (k) (#%$call-in-continuation k (#%$continuation-attachments k) (lambda () 9))))))
  (equal? 11 (+ 1 (call/cc (lambda (k) (* 0 (#%$call-in-continuation k (lambda () 10)))))))
  (equal? 'done (let ([maybe-k (call/cc (lambda (k) k))])
                  (if (symbol? maybe-k)
                      maybe-k
                      (* 0 (#%$call-in-continuation maybe-k (lambda () 'done))))))
  (equal? 'second (let-values ([(maybe-k result) (call/cc (lambda (k) (values k #f)))])
                    (if (symbol? maybe-k)
                        result
                        (* 0 (#%$call-in-continuation maybe-k (lambda () (values 'done 'second)))))))

  (equal? 10 (+ 1 (call/cc (lambda (k) (call-in-continuation k (lambda () 9))))))
  (equal? 10 (+ 1 (call/cc (lambda (k) (call-in-continuation k (continuation-next-marks k) (lambda () 9))))))
  (equal? 11 (+ 1 (call/cc (lambda (k) (* 0 (call-in-continuation k (lambda () 10)))))))
  (equal? 'done (let ([maybe-k (call/cc (lambda (k) k))])
                  (if (symbol? maybe-k)
                      maybe-k
                      (* 0 (call-in-continuation maybe-k (lambda () 'done))))))
  (equal? 'second (let-values ([(maybe-k result) (call/cc (lambda (k) (values k #f)))])
                    (if (symbol? maybe-k)
                        result
                        (* 0 (call-in-continuation maybe-k (lambda () (values 'done 'second)))))))

  (begin
    (define (attachments-in-continuation k)
      (#%$call-in-continuation
       k
       (lambda ()
         (#%$current-attachments))))
    (define (same-attachments-in-continuation k)
      (#%$call-in-continuation
       k
       (#%$current-attachments)
       (lambda ()
         (#%$current-attachments))))
    (define (sub-attachments-in-continuation k)
      (#%$call-in-continuation
       k
       (#%$current-attachments)
       (lambda ()
         (#%$call-setting-continuation-attachment
          'inside2
          (lambda ()
            (#%$current-attachments))))))
    #t)

  (equal? '(outside)
          (#%$call-setting-continuation-attachment
           'outside
           (lambda ()
             (#%$value
              (#%$call-setting-continuation-attachment
               'tail
               (lambda ()
                 (call/cc
                  (lambda (k)
                    (#%$call-setting-continuation-attachment
                     'inside
                     (lambda ()
                       (+ 1
                          (attachments-in-continuation k))))))))))))

  (equal? '(inside outside)
          (#%$call-setting-continuation-attachment
           'outside
           (lambda ()
             (#%$value
              (#%$call-setting-continuation-attachment
               'tail
               (lambda ()
                 (call/cc
                  (lambda (k)
                    (#%$call-setting-continuation-attachment
                     'inside
                     (lambda ()
                       (+ 1
                          (same-attachments-in-continuation k))))))))))))

  (equal? '(inside2 outside)
          (#%$call-setting-continuation-attachment
           'outside
           (lambda ()
             (#%$value
              (#%$call-setting-continuation-attachment
               'tail
               (lambda ()
                 (call/cc
                  (lambda (k)
                    (#%$call-setting-continuation-attachment
                     'inside
                     (lambda ()
                       (+ 1
                          (sub-attachments-in-continuation k))))))))))))

  (equal? '(unknown)
          (list
           (call/cc
            (lambda (k)
              (#%$call-consuming-continuation-attachment
               'unknown
               (lambda (v)
                 (#%$call-in-continuation
                  k
                  (lambda () v))))))))

  (equal? '(also-unknown)
          (list
           (call/cc
            (lambda (k)
              (#%$call-in-continuation
               k
               (lambda () 
                 (#%$call-consuming-continuation-attachment
                  'also-unknown
                  (lambda (v)
                    v))))))))

  (equal? '(known)
          (list
           (call/cc
            (lambda (k)
              (#%$call-in-continuation
               k
               (lambda ()
                 (#%$call-setting-continuation-attachment
                  'known
                  (lambda ()
                    (#%$call-getting-continuation-attachment
                     'still-unknown
                     (lambda (v)
                       v))))))))))

  (equal? '(here in out)
          (let ([did '()])
            (let ([k (dynamic-wind
                         (lambda () (set! did (cons 'in did)))
                         (lambda () (call/cc (lambda (k) k)))
                         (lambda () (void)))])
              (cond
               [(procedure? k)
                (set! did '())
                (dynamic-wind
                    (lambda () (void))
                    (lambda () (#%$call-in-continuation
                                k
                                (lambda ()
                                  (set! did (cons 'here did))
                                  'no)))
                    (lambda () (set! did (cons 'out did))))]
               [else did]))))

  ;; regression test to make sure the compiler doesn't run out of
  ;; registers:
  (procedure? (lambda (f a b c)
                (#3%call-with-values
                 (lambda ()
                   (#3%call-with-values
                    (lambda ()
                      (#%$call-setting-continuation-attachment
                       1024
                       (lambda ()
                         (#3%$app f a b c))))
                    fx+/carry))
                 f)))
)

;;; 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)))))
   ;; same for ordered:
   (with-interrupts-disabled
      (let ([x (make-guardian #t)])
         (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))))))
   ;; same for ordered:
   (with-interrupts-disabled
      (let ([x1 (make-guardian #t)])
         ; counting on a little compiler cleanliness here...
         (let ([x2 (make-guardian #t)])
            (x1 x2)
            (x2 x2))
         (collect)
         (let ([x2 (x1)])
            (and (equal? (x2) x2)
                 (not (x1))
                 (not (x2))))))
   (parameterize ([collect-trip-bytes (expt 2 24)]
                  [collect-maximum-generation-threshold-factor 0])
     (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)))
   ;; same for ordered:
   (parameterize ([collect-trip-bytes (expt 2 24)]
                  [collect-maximum-generation-threshold-factor 0])
     (let ([k 1000000])
       (let ([g (make-guardian #t)])
         (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)))))
   ;; same for ordered:
   (with-interrupts-disabled
      (let ([x (make-guardian #t)])
         (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)))))
   ;; same for ordered:
   (with-interrupts-disabled
      (let ([x (make-guardian #t)])
         (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)))))
   ;; same for ordered:
   (with-interrupts-disabled
      (let ([x (make-guardian #t)])
         (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)))
   ;; same for ordered:
   (equal?
     (with-interrupts-disabled
       (let ([g1 (make-guardian #t)] [g2 (make-guardian #t)])
         (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)
   ;; same for ordered:
   (eq? (with-interrupts-disabled
          (let* ([g (make-guardian #t)] [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)

   (begin
     (define (measure-guardian-chain-time n get-key ordered?)
       ;; Create a chain of guardians `n` long and
       ;; report how long a collection takes averaged
       ;; over `iters` tries
       (define iters 10)
       (let loop ([g #f] [accum 0] [j iters] [iters-mult 1])
         (if (zero? j)
             (if (zero? accum)
                 ;; more iterations to get non-0 CPU time:
                 (loop g accum iters (add1 iters-mult))
                 (begin
                   (keep-live g)
                   (/ accum (* iters iters-mult))))
             (let ([g (let loop ([i n])
                        (let ([g (make-guardian ordered?)])
                          (if (zero? i)
                              g
                              (let ([next-g (loop (sub1 i))])
                                (g (get-key next-g) next-g)
                                g))))])
               (let ([start (current-time 'time-process)])
                 (collect (collect-maximum-generation))
                 (let ([delta (time-difference (current-time 'time-process) start)])
                   (loop g
                         (+ accum
                            (* (time-second delta) 1e9)
                            (time-nanosecond delta))
                         (sub1 j)
                         iters-mult)))))))

     ;; Make sure guardian chains imply GC times that
     ;; look linear, as opposed to quadratic
     (define (ok-relative-guardian-chain-time? get-key ordered?)
       (let loop ([tries 3])
         (or (< (/ (measure-guardian-chain-time 10000 get-key ordered?)
                   (measure-guardian-chain-time 1000 get-key ordered?))
                50)
             (and (positive? tries)
                  (loop (sub1 tries))))))

     (and (ok-relative-guardian-chain-time? values #f)
          (ok-relative-guardian-chain-time? values #t)
          (let ([obj (gensym)])
            (and
             (ok-relative-guardian-chain-time? (lambda (x) obj) #f)
             (ok-relative-guardian-chain-time? (lambda (x) obj) #t)))))

   ;; Ordered finalization as different from unordred:
   (with-interrupts-disabled
    (let ([g1 (make-guardian #t)]
          [g2 (make-guardian #t)]
          [s (gensym)])
      (g1 s)
      (g2 (list s)) ; delays readying `s` in `g1`
      (set! s #f)
      (collect 0 0)
      (and (list? (g2))
           (not (g1))
           (begin
             (collect 0 0)
             (and (symbol? (g1))
                  (not (g2)))))))
   ;; Unordered is different:
   (with-interrupts-disabled
    (let ([g1 (make-guardian #f)]
          [g2 (make-guardian #f)]
          [s (gensym)])
      (g1 s)
      (g2 (list s)) ; no delay
      (set! s #f)
      (collect 0 0)
      (and (list? (g2))
           (symbol? (g1))
           (begin
             (collect 0 0)
             (and (not (g1))
                  (not (g2)))))))

   ;; cycle ok with unordered
   (let ([g (make-guardian)])
     (let ([s (gensym)])
       (g s (list s)))
     (collect)
     (list? (g)))
   ;; cycle not ok with ordered
   (let ([g (make-guardian #t)])
     (let ([s (gensym)])
       (g s (list s)))
     (collect)
     (not (g)))
   ;; self representative doesn't count as cycle
   (let ([g (make-guardian #t)])
     (let ([s (gensym)])
       (g s s))
     (collect)
     (symbol? (g)))
   ;; try a longer cycle:
   (let ([g (make-guardian #t)])
     (let ([hd (cons 0 '())])
       (set-cdr! hd
                 (let loop ([i 100])
                   (if (zero? i)
                       hd
                       (let ([p (cons i (loop (sub1 i)))])
                         (g p)
                         p)))))
     (collect)
     (not (g)))

   ;; same object, ordered and unordered => ordered first
   (with-interrupts-disabled
    (let ([g1 (make-guardian)]
          [g2 (make-guardian #t)])
      (let ([s (gensym)])
        (g1 s)
        (g2 s))
      (collect 0 0)
      (collect 0 0)
      (and (not (g2))
           (symbol? (g1))
           (not (g2))
           (begin
             (collect 0 0)
             (and (symbol? (g2))
                  (not (g1))
                  (not (g2)))))))

   ;; same object, both ordered => available from both
   (with-interrupts-disabled
    (let ([g1 (make-guardian #t)]
          [g2 (make-guardian #t)])
      (let ([s (gensym)])
        (g1 s)
        (g2 s))
      (collect 0 0)
      (and (symbol? (g2))
           (symbol? (g1))
           (not (g1))
           (not (g2))
           (begin
             (collect 0 0)
             (and (not (g1))
                  (not (g2)))))))

   ;; check ordered finalization on objects that immediately
   ;; refer to themselves, which can create trouble for a naive
   ;; approach to determining accessibility
   (begin
     (define (check-self-referencing p extract)
       (with-interrupts-disabled
        (let ([g (make-guardian #t)])
          (g p)
          (let ([wb (weak-cons p #f)])
            (set! p #f)
            (collect 0 0)
            (let ([p (car wb)])
              (and (not (g))
                   (eq? p (extract p))))))))
     (let ([p (cons #f #f)])
       (set-car! p p)
       (check-self-referencing p car)))
   (let ([p (cons #f #f)])
     (set-cdr! p p)
     (check-self-referencing p cdr))
   (let ([p (cons #f #f)])
     (set-car! p p)
     (set-cdr! p p)
     (check-self-referencing p (lambda (p)
                                 (and (eq? (car p) (cdr p))
                                      (car p)))))
   (let ([b (box #f)])
     (set-box! b b)
     (check-self-referencing b unbox))
   (let ([f (letrec ([f (lambda () f)]) f)])
     (check-self-referencing f (lambda (f) (f))))
   (let ()
     (define-record-type self (fields (mutable v)))
     (let ([v (make-self #f)])
       (self-v-set! v v)
       (check-self-referencing v self-v)))

   (parameterize ([collect-request-handler void])
     (define (get-all g) (let ([q (g)]) (if q (cons q (get-all g)) '())))
     (module (insist)
       (define ($insist e? expr expected got)
         (unless (e? got expected)
           (errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
       (define-syntax insist
         (syntax-rules ()
           [(_ ?e? ?expr ?expected)
            ($insist ?e? '?expr ?expected ?expr)])))
     (let ([g1 (make-guardian)] [g2 (make-guardian)])
       (let ([x (box (cons 'a 'b))] [y (box (cons 'c 'd))])
         (insist eq? (unregister-guardian g1) '())
         (insist eq? (unregister-guardian g2) '())
         (g1 (unbox x))
         (g1 (unbox y))
         (g2 (unbox x))
         (g1 (unbox y))
         (g1 (unbox x))
         (collect 0 0)
         (g2 (unbox x))
         (g1 (cons 'e 'f))
         (g2 (unbox x))
         (g1 (unbox x))
         (g2 (cons 'g 'h))
         (insist eq? (get-all g1) '())
         (insist eq? (get-all g2) '())
         (let ([q (unregister-guardian g2)])
           (unless (and (= (length q) 4) (equal? (remove '(g . h) q) (list (unbox x) (unbox x) (unbox x))))
             (errorf #f "expected (unregister-guardian g2) to contain x = (a . b), x = (a . b), and (g . h), got ~s" q)))
         (insist eq? (unregister-guardian g2) '())
         (insist eq? (get-all g1) '())
         (insist eq? (get-all g2) '())
         (collect 0 0)
         (insist equal? (get-all g1) '((e . f)))
         (insist eq? (get-all g2) '())
         (g2 (unbox x))
         (set-box! x #f)
         (collect 0 0)
         (insist equal? (get-all g1) '((a . b) (a . b) (a . b)))
         (insist equal? (get-all g2) '((a . b)))
         (insist equal? (unregister-guardian g1) '((c . d) (c . d)))
         (insist eq? (unregister-guardian g2) '())
         (pretty-print (list g1 g2 x y)))) ; keep 'em live
     #t)
 )

(mat refcount-guardians
  (error? ; unrecognized ftype
    (ftype-guardian NO!))
  (error? ; first element must be a word-sized integer with native endianness
    (let ()
      (define-ftype A (struct))
      (ftype-guardian A)))
  (error? ; first element must be a word-sized integer with native endianness
    (let ()
      (define-ftype A (union [u1 (struct (refcount char))] [u2 (struct (foo (* A)))]))
      (ftype-guardian A)))
  (error? ; invalid ftype-guardian argument
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian A))
      (g (cons 'ka 'blooie))))
  (error? ; invalid ftype-guardian argument
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian A))
      (g (make-ftype-pointer iptr 0))))
  (eq?
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian iptr))
      (g (make-ftype-pointer A 0)))
    (void))
  (with-interrupts-disabled
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian A))
      (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
      (ftype-set! A (refcount) a 0)
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (eqv? (ftype-ref A (refcount) a) 1))
      (g a)
      (set! a #f)
      (collect 0 0)
      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
      (assert (not (g)))
      #t))
  (with-interrupts-disabled
    (let ()
      (define-ftype A (struct (refcount uptr) (x int)))
      (define g (ftype-guardian A))
      (define addr (foreign-alloc (ftype-sizeof A)))
      (define a1 (make-ftype-pointer A addr))
      (define a2 (make-ftype-pointer A addr))
      (define wpa1 (weak-cons a1 '()))
      (define wpa2 (weak-cons a2 '()))
      (ftype-set! A (refcount) a1 0)
      (ftype-set! A (x) a1 17)
      (assert (eqv? (ftype-ref A (x) a1) 17))
      (assert (eqv? (ftype-ref A (x) a2) 17))
      (assert (eqv? (ftype-ref A (refcount) a1) 0))
      (assert (eqv? (ftype-ref A (refcount) a2) 0))
      (assert (not (ftype-locked-incr! A (refcount) a1)))
      (assert (not (ftype-locked-incr! A (refcount) a2)))
      (assert (eqv? (ftype-ref A (refcount) a1) 2))
      (assert (eqv? (ftype-ref A (refcount) a2) 2))
      (g a1)
      (g a2)
      (collect 0 0)
      (assert (not (g)))
      (set! a1 #f)
      (collect 0 0)
      (assert (not (g)))
      (set! a2 #f)
      (collect 0 0)
      (set! a2 (g))
      (assert (eq? (car wpa2) a2))
      (assert (not (g)))
      (assert (eqv? (ftype-ref A (refcount) a2) 0))
      #t))
  (with-interrupts-disabled
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian A))
      (define regular-g (make-guardian))
      (define addr (foreign-alloc (ftype-sizeof A)))
      (define a (make-ftype-pointer A addr))
      (ftype-set! A (refcount) a 0)
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (eqv? (ftype-ref A (refcount) a) 1))
      (regular-g a)
      (g a)
      (regular-g a)
      (set! a #f)
      (collect 0 0)
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
      (assert (not (regular-g)))
      (assert (not (g)))
      #t))
  (with-interrupts-disabled
    (let ()
      (define-ftype A (struct (refcount uptr) (x int)))
      (define g (ftype-guardian A))
      (define regular-g (make-guardian))
      (define addr (foreign-alloc (ftype-sizeof A)))
      (define a (make-ftype-pointer A addr))
      (ftype-set! A (refcount) a 0)
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (eqv? (ftype-ref A (refcount) a) 2))
      (regular-g a)
      (g a)
      (regular-g a)
      (set! a #f)
      (collect 0 0)
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 1))
      (assert (not (regular-g)))
      (assert (not (g)))
      #t))
  (with-interrupts-disabled
    (let ()
      (define-ftype A (struct (refcount iptr) (x int)))
      (define g (ftype-guardian A))
      (define regular-g (make-guardian))
      (define addr (foreign-alloc (ftype-sizeof A)))
      (define a (make-ftype-pointer A addr))
      (ftype-set! A (refcount) a 0)
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (not (ftype-locked-incr! A (refcount) a)))
      (assert (eqv? (ftype-ref A (refcount) a) 2))
      (regular-g a)
      (g a)
      (g a)
      (regular-g a)
      (set! a #f)
      (collect 0 0)
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
      (assert (eqv? (ftype-ref A (refcount) (regular-g)) 0))
      (assert (eqv? (ftype-ref A (refcount) (g)) 0))
      (assert (not (regular-g)))
      (assert (not (g)))
      #t))

   (parameterize ([collect-request-handler void])
     (define-ftype A (struct (refcount iptr) (uid int)))
     (define (get-all g)
       (let ([a (g)])
         (if a
             (begin
               (unless (eqv? (ftype-ref A (refcount) a) 0)
                 (errorf 'get-all "nonzero refcount ~s, uid ~s" (ftype-ref A (refcount) a) (ftype-ref A (uid) a)))
               (cons a (get-all g)))
             '())))
     (module (insist)
       (define ($insist e? expr expected got)
         (unless (e? got expected)
           (errorf #f "expected ~s to return ~s, got ~s" expr expected got)))
       (define-syntax insist
         (syntax-rules ()
           [(_ ?e? ?expr ?expected)
            ($insist ?e? '?expr ?expected ?expr)])))
     (define (get-uid a) (ftype-ref A (uid) a))
     (define (fritter addr refcount uid)
       (let ([a (make-ftype-pointer A addr)])
         (ftype-set! A (refcount) a refcount)
         (ftype-set! A (uid) a uid)
         (box a)))
     (let ([x-addr (foreign-alloc (ftype-sizeof A))] [y-addr (foreign-alloc (ftype-sizeof A))] [z-addr (foreign-alloc (ftype-sizeof A))])
       (let ([x1 (fritter x-addr 6 73)] [x2 (box (make-ftype-pointer A x-addr))] [y (fritter y-addr 2 57)] [z (fritter z-addr 2 91)])
         (let ([g1 (ftype-guardian A)] [g2 (ftype-guardian A)])
           (insist eq? (unregister-guardian g1) '())
           (insist eq? (unregister-guardian g2) '())
           (g1 (unbox x1))
           (g2 (unbox x1))
           (g1 (unbox x1))
           (g1 (unbox x2))
           (g2 (unbox x1))
           (g1 (unbox y))
           (g1 (unbox y))
           (g2 (unbox z))
           (g1 (unbox z))
           (insist eq? (get-all g1) '())
           (insist eq? (get-all g2) '())
           (let ([q (unregister-guardian g2)])
             (define (decr-refcount! a) (ftype-locked-decr! A (refcount) a))
             (unless (and (= (length q) 3) (memq (unbox x1) (memq (unbox x1) q)) (memq (unbox z) q))
               (errorf #f "expected (unregister-guardian g2) to contain x/uid 73, x/uid 73, and z/uid 91, got ~s" (map get-uid q)))
             (map decr-refcount! q))
           (insist eq? (unregister-guardian g2) '())
           (insist eq? (get-all g1) '())
           (insist eq? (get-all g2) '())
           (pretty-print z) ; keep it live
           (set-box! z #f)
           (collect 0 0)
           (insist equal? (map get-uid (get-all g1)) '(91))
           (insist eq? (get-all g2) '())
           (g2 (unbox x1))
           (pretty-print x1) ; keep it live
           (set-box! x1 #f)
           (collect 0 0)
           (insist eq? (get-all g1) '())
           (insist eq? (get-all g2) '())
           (insist eq? (unregister-guardian g2) '())
           (insist eqv? (ftype-ref A (refcount) (unbox x2)) 1)
           (pretty-print x2) ; keep it live
           (set-box! x2 #f)
           (collect 0 0)
           (insist equal? (map get-uid (get-all g1)) '(73))
           (insist equal? (map get-uid (get-all g2)) '())
           (insist eq? (unregister-guardian g2) '())
           (pretty-print y) ; keep it live
           (set-box! y #f)
           (collect 0 0)
           (insist equal? (map get-uid (get-all g1)) '(57))
           (insist equal? (map get-uid (get-all g2)) '())
           (insist eq? (unregister-guardian g1) '())
           (insist eq? (unregister-guardian g2) '())
           (pretty-print (list g1 g2 x y)))) ; keep 'em live
       (foreign-free x-addr)
       (foreign-free y-addr)
       (foreign-free z-addr))
     #t)
  )

(mat weak-cons
   (procedure? weak-cons)
   (procedure? weak-pair?)
   (with-interrupts-disabled
      (let ([x (weak-cons (cons 'a 'b) 'c)])
         (and (equal? (car x) '(a . b))
              (begin (collect) (bwp-object? (car x)))
              (begin (set-car! x (cons 'd 'e)) (equal? (car x) '(d . e)))
              (begin (collect (collect-maximum-generation))
                     (bwp-object? (car x))))))
   ;; check interaction of weak pairs, generations, and specific target generations for collection
   (with-interrupts-disabled
    (parameterize ([#%$enable-check-heap #t]
                   [collect-maximum-generation (max (collect-maximum-generation) 2)])
      (let ([key "key"])
        (let ([e (weak-cons key #f)])
          (collect 0 1 1)
          (let ([key2 (gensym key)])
            ;; e is gen 1, key2 is gen 0:
            (set-car! e key2)
            (collect 1 1 2)
            ;; Now, e is gen 1, key2 is gen 0
            (and (eq? (car e) key2)
                 (begin
                   (collect 1 2 2)
                   ;; Check that the GC update the reference to `key2` in `e`:
                   (eq? (car e) key2))))))))
 )

(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 'time-process)])
             (collect 0 1)
             (collect 1 2)
             (collect 2 2)
             (let ([delta (time-difference (current-time 'time-process) start)])
               ;; Sanity check on ephemerons
               (for-each (lambda (e)
                           (when (eq? #!bwp (ephemeron-key e))
                             (error 'check "oops")))
                         es)
               ;; Keep `root` and `holds` live:
               (keep-alive (cons root holds))
               ;; Return duration:
               delta)))))

     (define N 10000)

     ;; The first time should be roughy x10 the second (not x100)
     (let loop ([tries 3])
       (define dummy #f)
       (define (keep-alive v) (set! dummy (cons dummy v)))
       (define t1 (measure-time (* 10 N) keep-alive))
       (define dummy2 (set! dummy #f))
       (define t2 (measure-time N keep-alive))
       (define (duration->inexact t) (+ (* (time-second t) 1e9)
                                        (inexact (time-nanosecond t))))
       (set! dummy #f)
       (let ([t1 (duration->inexact t1)] [t2 (duration->inexact t2)])
         (or (< (/ t1 t2) 20)
           (begin
             (printf "t1 = ~s, t2 = ~s, t1/t2 = ~s\n" t1 t2 (/ t1 t2))
             (and (positive? tries)
               (loop (sub1 tries))))))))

   ;; ----------------------------------------
   ;; Check interaction of mutation and generations
   
   ;; This check disables interrupts so that a garbage collection
   ;; happens only for the explicit `collect` request.
   (with-interrupts-disabled
     (let ([e (ephemeron-cons (gensym) 'ok)])
       (collect 0) ; => `e` is moved to generation 1
       (and
         (eq? #!bwp (ephemeron-key e))
         (eq? #!bwp (ephemeron-value e))
         (let ([s (gensym)])
           (set-car! e s)
           (set-cdr! e 'ok-again)
           (collect 0) ; => `s` is moved to generation 1
           (and
             (eq? s (ephemeron-key e))
             (eq? 'ok-again (ephemeron-value e))
             (begin
               (set! s #f)
               (collect 1) ; collect former `s`
               (and
                 (eq? #!bwp (ephemeron-key e))
                 (eq? #!bwp (ephemeron-value e)))))))))

   ;; ----------------------------------------
   ;; Check interaction of mutation and incremental generation promotion

   (with-interrupts-disabled
    (parameterize ([#%$enable-check-heap #t]
                   [collect-maximum-generation (max (collect-maximum-generation) 2)])
      (let ([key "key"])
        (let ([e (ephemeron-cons key #f)])
          (collect 0 1 1)
          (let ([key2 (gensym key)])
            ;; e is gen 1, key2 is gen 0:
            (set-car! e key2)
            (collect 1 1 2)
            ;; Now, e is gen 1, key2 is gen 0
            (and (eq? (car e) key2)
                 (begin
                   (collect 1 2 2)
                   ;; Check that the GC update the reference to `key2` in `e`:
                   (eq? (car e) key2))))))))

   ;; ----------------------------------------
   ;; Check GC interaction with zero-sized contnuations - unlikely
   ;; to crash even if things are wrong, but it's worth a try

   (let ()
     (define (loop i)
       (if (zero? i)
           (call/cc (lambda (k) (k '())))
           (let ([keeps (loop (sub1 i))])
             (call/cc
              (lambda (k)
                (cons k keeps))))))

     (with-interrupts-disabled
      (collect 0)
      (let ([keeps (filter (lambda (c)
                             (eqv? 0 (#%$continuation-stack-clength c)))
                           (loop 1000))])
        ;; The `keeps` list is probably non-empty
        (collect 0 0)
        (collect 0 0)
        (keep-live keeps)
        #t)))

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