(module r6rs-tests mzscheme
  (require (lib "match.ss")
           (lib "list.ss")
           (lib "etc.ss")
           (planet "reduction-semantics.ss" ("robby" "redex.plt" 4))
           "test.scm"
           "r6rs.scm")
  
  ;; ============================================================
  ;; TESTING APPARATUS
  
  (define-struct r6test (test expected))
  
  (define (make-r6test/v t expected) 
    (make-r6test `(store () ,t)
                 (list `(store () (values ,expected)))))
  (define (make-r6test/e t err)
    (make-r6test `(store () ,t)
                 (list `(uncaught-exception (make-cond ,err)))))
  
  (define (run-a-test test verbose?)
    (unless verbose?
      (printf ".") 
      (flush-output))
    (let ([t (r6test-test test)]
          [expected (r6test-expected test)])
      (set! test-count (+ test-count 1))
      (when verbose? (printf "testing ~s ... " t))
      (flush-output)
      (with-handlers ([exn:fail:duplicate?
                       (lambda (e)
                         (set! failed-tests (+ failed-tests 1))
                         (unless verbose? 
                           (printf "\ntesting ~s ... " t))
                         (raise e))])
        (let* ([results (evaluate reductions
                                  t
                                  (or verbose? 'dots)
                                  (verify-p* t))]
               [rewritten-results (remove-duplicates (map rewrite-actual results))])
          (for-each (verify-a* t) results)
          (unless (set-same? expected rewritten-results equal?)
	    (set! failed-tests (+ failed-tests 1))
            (unless verbose? 
              (printf "\ntesting ~s ... " t))
	    (printf "TEST FAILED!~nexpected:~a\nrewritten-received:~a\nreceived:~a\n\n"
		    (combine-in-lines expected)
		    (combine-in-lines rewritten-results)
                    (combine-in-lines results)))))))
  
  (define p*-pattern (test-match lang p*))
  (define a*-pattern (test-match lang a*))
  (define r*-pattern (test-match lang r*))
  (define verified-terms 0)
  (define ((verify-p* orig) sexp)
    (let ([m (p*-pattern sexp)])
      (unless (and m
                   (= 1 (length m)))
        (newline)
        (error 'verify-p* "matched ~a times\n ~s\norig\n ~s" 
               (if m
                   (length m)
                   "0")
               sexp orig))
      (set! verified-terms (+ verified-terms 1))))
  
  (define ((verify-a* orig-sexp) sexp)
    (unless (a*-pattern sexp)
      (newline) 
      (error 'verify-a* "didn't match ~s\noriginal term ~s" sexp orig-sexp))
    
    ;; verify that observable is defined for this value
    (let ([candidate-r* (term-let ((sexp sexp))
                          (term (observable sexp)))])
      (unless (r*-pattern candidate-r*)
        (error 'verify-a* "observable of ~s is ~s, but isn't an r*\noriginal term ~s"
               sexp
               candidate-r*
               orig-sexp))))
  
  (define (remove-duplicates lst)
    (let ([ht (make-hash-table 'equal)])
      (for-each (λ (x) (hash-table-put! ht x #t)) lst)
      (hash-table-map ht (λ (x y) x))))
  
  (define (combine-in-lines strs) (apply string-append (map (λ (x) (format "\n  ~s" x)) strs)))
  
  (define (rewrite-actual actual)
    (match actual
      [`(unknown ,str) actual]
      [`(uncaught-exception ,v) actual]
      [`(store ,@(xs ...)) 
       (let loop ([actual actual])
         (subst-:-vars actual))]
      [_
       (error 'rewrite-actual "unknown actual ~s\n" actual)]))
  
  (define (subst-:-vars exp)
    (match exp
      [`(store ,str ,exps ...)
       (let* ([pp-var? (λ (x) (regexp-match #rx"^[qmi]p" (format "~a" (car x))))]
              [pp-bindings (filter pp-var? str)]
              [with-out-pp (fp-sub pp-bindings `(store ,(filter (λ (x) (not (pp-var? x))) str) ,@exps))]
              [with-out-app-vars (remove-unassigned-app-vars with-out-pp)]
              [without-ri-vars (remove-unused-ri-vars with-out-app-vars)])
         without-ri-vars)]
      [`(unknown ,string) string]
      [_ (error 'subst-:-vars "unknown exp ~s" exp)]))
  
  (define (is-ri-var? x) (regexp-match #rx"^ri" (symbol->string x)))
  
  (define (remove-unused-ri-vars exp)
    (match exp
      [`(store ,str ,exps ...)
       (let ([ri-vars (filter is-ri-var? (map car str))]
             [str-without-ri-binders 
              (filter (λ (binding) (not (is-ri-var? (car binding)))) str)])
         `(store ,(filter (λ (binding) 
                            (cond
                              [(is-ri-var? (car binding)) 
                               (not (not-in (car binding) (cons str-without-ri-binders exps)))]
                              [else #t]))
                          str)
            ,@exps))]))
  
  (define (remove-unassigned-app-vars term)
    (match term 
      [`(store ,bindings ,body)
       (let* ([binding-rhss (map cadr bindings)]
              [bindings-to-sub 
               (filter (λ (binding) (not (appears-in-set? (car binding) body)))
                       (filter (λ (binding) (regexp-match #rx"^bp" (format "~a" (car binding)))) bindings))]
              [vars-to-sub (map car bindings-to-sub)])
         `(store ,(filter (λ (binding) (not (memq (car binding) vars-to-sub))) bindings)
            ,(r6-all bindings-to-sub body)))]))
  
  (define (not-in var e)
    (cond
      [(pair? e) (and (not-in var (car e))
                      (not-in var (cdr e)))]
      [else (not (eq? var e))]))
  
  (define (appears-in-set? x e)
    (let loop ([e e])
      (match e
        [`(set! ,x2 ,e2) (or (eq? x x2)
                             (loop e2))]
        [else
         (and (list? e) 
              (ormap loop e))])))
           
  
  (define (fp-sub bindings term)
    (let loop ([term term])
      (let ([next (do-one-subst bindings term)])
        (cond 
          [(equal? term next) next]
          [else (loop next)]))))
  
  (define (r6-all sub-vars body)
    (term-let ([(sub-vars ...) sub-vars]
               [body body])
      (term (r6rs-subst-many (sub-vars ... body)))))
  
  (define (do-one-subst sub-vars term)
    (match term
      [`(store ,str ,exps ...)
       (let* ([keep-vars 
               (map (λ (pr)
                      `(,(car pr)
                        ,(r6-all sub-vars (cadr pr))))
                    str)])
         `(store ,keep-vars ,@(r6-all sub-vars exps)))]))
  
  (define test-count 0)
  (define failed-tests 0)
  
  (define arithmetic-tests
    (list
     (make-r6test/v '(+) 0)
     (make-r6test/v '(+ 1) 1)
     (make-r6test/v '(+ 1 2) 3)
     (make-r6test/v '(+ 1 2 3) 6)
     
     (make-r6test/v '(- 1) -1)
     (make-r6test/v '(- 1 2) -1)
     (make-r6test/v '(- 1 2 3) -4)
     
     (make-r6test/v '(*) 1)
     (make-r6test/v '(* 2) 2)
     (make-r6test/v '(* 2 3) 6)
     (make-r6test/v '(* 2 3 4) 24)
     
     (make-r6test/v '(/ 2) 1/2)
     (make-r6test/v '(/ 1 2) 1/2)
     (make-r6test/v '(/ 1 2 3) 1/6)
     
     (make-r6test/e '(/ #f) "arith-op applied to non-number")
     
     (make-r6test/e '(/ 1 2 3 4 5 0 6) "divison by zero")
     (make-r6test/e '(/ 0) "divison by zero")
     
     (make-r6test '(store () ((lambda (x) (+ x x)) #f))
                  (list '(uncaught-exception (make-cond "arith-op applied to non-number"))))))
  
  (define assignment-results-tests
    (list
     ;; begin
     (make-r6test/v '((lambda (x) (begin x (set! x 2) x)) 3)
                    2)
     (make-r6test '(store () (letrec ([x 1]) (begin 2 (set! x 2))))
                  (list '(unknown "unspecified result")))

     ;; begin0 
     (make-r6test/v '((lambda (x) (begin0 x (set! x 2))) 3)
                    3)
     (make-r6test '(store () (letrec ([x 1]) (begin0 (set! x 2) 2 3)))
                  (list '(unknown "unspecified result")))
     (make-r6test/v '((lambda (x) (begin (begin0 (set! x 1) (set! x 2)) x)) 3)
                    2)
     
     
     ;; application
     (make-r6test '(store () (letrec ([x 1]) ((lambda (x) 1) (set! x 2))))
                  (list '(unknown "unspecified result")))
     (make-r6test '(store () (letrec ([x 1]) ((set! x 2) 2)))
                  (list '(unknown "unspecified result")))
     
     ;; if
     (make-r6test '(store () (letrec ([x 1]) (if (set! x 2) 2 3)))
                  (list '(unknown "unspecified result")))
     
     ;; set!
     (make-r6test '(store () (letrec ([x 1]) (set! x (set! x 2))))
                  (list '(unknown "unspecified result")))
     
     (make-r6test '(store () (letrec ([x '(1)]) (set! x (set-car! x 2))))
                  (list '(unknown "unspecified result")
                        '(uncaught-exception (make-cond "can't set-car! on a non-pair or an immutable pair"))))
     
     ;; handlers
     (make-r6test '(store () (letrec ([x 1]) (with-exception-handler (lambda (e) (set! x 2)) (lambda () (car 'x)))))
                  (list '(uncaught-exception (make-cond "handler returned"))))
     
     ;; call with values
     (make-r6test '(store () (letrec ([x 1]) (call-with-values (lambda () (set! x 2)) +)))
                  (list '(unknown "unspecified result")))
     
     ;; dynamic-wind
     (make-r6test/v '((lambda (x) (dynamic-wind (lambda () (set! x 0)) (lambda () x) (lambda () (set! x 2)))) 1)
                    0)
     (make-r6test '(store () (letrec ([x 1]) (dynamic-wind (lambda () 0) (lambda () (set! x 2)) (lambda () 1))))
                  (list '(unknown "unspecified result")))
     (make-r6test '(store () (letrec ([x 1]) (begin (dynamic-wind (lambda () 0) (lambda () (set! x 2)) (lambda () 1)) 5)))
                  (list '(store ((lx-x 2)) (values 5))))
     
     ;; letrec
     ;; bug one that Casey found
     (make-r6test '(store () (letrec* ([y 1] [x (set! y 2)]) y))
                  (list '(unknown "unspecified result")))))
  
  (define basic-form-tests
    (list
     
     (make-r6test/e '((lambda (x y) x) (lambda (x) x))
                    "arity mismatch")
     
     (make-r6test/v '(if #t 12 13) 12)
     (make-r6test/v '(if #f 12 13) 13)
     (make-r6test/v '(begin (if #f 12 14) 14) 14)
     (make-r6test/v '((lambda (x) (if #t (set! x 45) 'x) x) 1) 45)
     (make-r6test/v '((lambda (x) (if #f (set! x 45) 'z) x) 1) 1)
     
     ;; begin0 tests
     (make-r6test/v '(begin0 (+ 1 1))
                    2)
     (make-r6test/v '(begin0 (+ 1 1) (+ 2 3))
                    2)
     (make-r6test/v '((lambda (x) (begin0 x (set! x 4))) 2)
                    2)
     (make-r6test/v '(((lambda (x) (begin0 (lambda () x) (set! x (+ x 1)) (set! x (+ x 1)) (set! x (+ x 1))))
                       2))
                    5)))
  
  (define pair-tests
    (list
     (make-r6test/v '(if (null? (cons 1 (cons 2 (cons (lambda (x) x) null)))) 0 1) 
                    1)
     (make-r6test/v '(null? (cons 1 (cons 2 (cons (lambda (x) x) null)))) #f)
     (make-r6test/v '(null? (cons 1 2)) #f)
     (make-r6test/v '(null? null) #t)
     (make-r6test/v '(pair? null) #f)
     (make-r6test/v '(pair? (cons 1 1)) #t)
     (make-r6test/v '(null? (list 1 2)) #f)
     (make-r6test/v '(pair? (list 1)) #t)
     (make-r6test/v '(pair? (list)) #f)
     (make-r6test/v '(null? (list)) #t)
     
     (make-r6test/v '((lambda (x) ((lambda (y) (car (cdr x))) (begin (set-car! (cdr x) 400) 11))) 
                      (cons 1 (cons 2 null)))
                    400)
     (make-r6test/v '((lambda (x) ((lambda (y) (cdr (cdr x))) (begin (set-cdr! (cdr x) 400) 12)))
                      (cons 1 (cons 2 null))) 
                    400)
     (make-r6test '(store () ((lambda (x) (set-cdr! x 4) (cdr x)) '(3)))
                  (list '(store () (values 4))
                        '(uncaught-exception (make-cond "can't set-cdr! on a non-pair or an immutable pair"))))
     (make-r6test '(store () ((lambda (x) (set-car! x 4) (car x)) '(3)))
                  (list '(store () (values 4))
                        '(uncaught-exception (make-cond "can't set-car! on a non-pair or an immutable pair"))))
     
     (make-r6test '(store ()
                     (letrec ([first-time? #t]
                              [f (lambda y (if first-time?
                                               (begin
                                                 (set! first-time? #f)
                                                 (set-car! y 2))
                                               (car y)))]
                              [g (lambda () (apply f '(1)))])
                       (g)
                       (g)))
                  (list '(store ((lx-first-time? #f)
                                 (lx-f (lambda y (if lx-first-time?
                                                     (begin
                                                       (set! lx-first-time? #f)
                                                       (set-car! y 2))
                                                     (car y))))
                                 (lx-g (lambda () (apply lx-f (cons 1 null)))))
                           (values 1))))))
  
  (define quote-tests
    (list
     (make-r6test/v ''#f #f)
     (make-r6test/v ''#t #t)
     (make-r6test/v ''1 1)
     (make-r6test/v ''x ''x)
     (make-r6test/v ''null ''null)
     (make-r6test/v '(null? 'null) #f)
     (make-r6test/v ''unspecified ''unspecified)
     (make-r6test/v '((lambda (x) (eqv? 'x 1)) 1) #f)))
  
  (define eqv-tests
    (list
     (make-r6test '(store () (eqv? (lambda (x) x) (lambda (x) x)))
                  (list '(unknown "equivalence of procedures")))
     (make-r6test '(store () (eqv? (lambda (x) x) (lambda (x) x)))
                  (list '(unknown "equivalence of procedures")))
     (make-r6test '(store () ((lambda (x) (eqv? x x)) (lambda (x) x)))
                  (list '(unknown "equivalence of procedures")))
     
     (make-r6test/v '(eqv? (cons 1 2) (cons 1 2)) #f)
     (make-r6test/v '((lambda (x) (eqv? x x)) (cons 1 2)) #t)
     
     (make-r6test '(store () (apply apply values '(())))
                  (list '(store () (values))))
     
     (make-r6test/v '(eqv? #t #t) #t)
     (make-r6test/v '(eqv? #t #f) #f)
     
     (make-r6test/v '(eqv? 'x 'y) #f)
     (make-r6test/v '(eqv? 'y 'y) #t)
     
     (make-r6test/v '(eqv? (lambda (x) x) #t) #f)
     (make-r6test/v '(eqv? #t (lambda (x) x)) #f)
     (make-r6test/v '(eqv? '() null) #t)
     
     (make-r6test '(store () (eqv? '(a) '(a))) 
                  (list '(store () (values #f))))
     (make-r6test '(store () (eqv? '(a) '(b))) 
                  (list '(store () (values #f))))
     (make-r6test '(store () ((lambda (x) (eqv? x x)) '(a)))
                  (list '(store () (values #t))))
     
     (make-r6test '(store ()
                     (eqv?
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x)))))
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car)))))))
                  (list '(store () (values #f))
                        '(store () (values #t))))
     (make-r6test '(store ()
                     ((lambda (x) (eqv? x x))
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x)))))))
                  (list '(store () (values #f))
                        '(store () (values #t))))
     
     (make-r6test/v '(eqv?
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x)))))
                      #f)
                    #f)
     (make-r6test/v '(eqv?
                      #f
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x))))))
                    #f)
     (make-r6test/v '(eqv?
                      (lambda (x) x)
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x))))))
                    #f)
     (make-r6test/v '(eqv?
                      (call/cc
                       (lambda (k)
                         (with-exception-handler
                          k
                          (lambda () (car 'x)))))
                      (lambda (x) x))
                    #f)))
  
  (define err-tests
    (list
     
     (make-r6test/e '(call-with-values (lambda (x) x) (lambda (y) y))
                    "arity mismatch")
     (make-r6test/e '(/) "arity mismatch")
     (make-r6test/e '(-) "arity mismatch")
     (make-r6test/e '(cons) "arity mismatch")
     (make-r6test/e '(null?) "arity mismatch")
     (make-r6test/e '(pair?) "arity mismatch")
     (make-r6test/e '(car) "arity mismatch")
     (make-r6test/e '(cdr) "arity mismatch")
     (make-r6test/e '(set-car!) "arity mismatch")
     (make-r6test/e '(set-cdr!) "arity mismatch")
     (make-r6test/e '(call/cc) "arity mismatch")
     (make-r6test/e '(eqv?) "arity mismatch")
     (make-r6test/e '(apply) "arity mismatch")
     (make-r6test/e '(apply values) "arity mismatch")
     (make-r6test/e '(call-with-values) "arity mismatch")
     
     (make-r6test/e '(dynamic-wind 1) "arity mismatch")
     
     (make-r6test/e '(apply 1 2) "can't apply non-procedure")
     (make-r6test/e '(apply 1 null) "can't apply non-procedure")
     (make-r6test/e '(apply values 2) "apply's last argument non-list")
     (make-r6test/e '(car 1) "can't take car of non-pair")
     (make-r6test/e '(cdr 1) "can't take cdr of non-pair")
     (make-r6test/e '(set-car! 2 1) "can't set-car! on a non-pair or an immutable pair")
     (make-r6test/e '(set-cdr! 1 2) "can't set-cdr! on a non-pair or an immutable pair")
     
     (make-r6test/e '(call/cc 1) "can't call non-procedure")
     (make-r6test/e '(call-with-values 1 2) "can't call non-procedure")))
  
  (define r5-tests
    (list
     
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;;
     ;; tests from R5RS
     ;;
     
     ; ----
     ; 4.1.3
     (make-r6test/v '(+ 3 4) 7)
     (make-r6test/v '((if #f + *) 3 4) 12)
     
     
     ; ----
     ; 4.1.4
     (make-r6test/v '(lambda (x) (+ x x)) '(lambda (x) (+ x x)))
     (make-r6test/v '((lambda (x) (+ x x)) 4) 8)
     
     (make-r6test '(store ()
                     (letrec* ([reverse-subtract
                                (lambda (x y) (- y x))])
                       (reverse-subtract 7 10)))
                  (list
                   '(store ((lx-reverse-subtract (lambda (x y) (- y x))))
                      (values 3))))
     
     (make-r6test '(store ()
                     (letrec* ([add4
                                ((lambda (x)
                                   (lambda (y)
                                     (+ x y)))
                                 4)])
                       (add4 6)))
                  (list
                   '(store ((lx-add4 (lambda (y) (+ 4 y))))
                      (values 10))))
     
     (make-r6test/v '((lambda x x) 3 4 5 6)
                    '(cons 3 (cons 4 (cons 5 (cons 6 null)))))
     (make-r6test/v '((lambda (x y dot z) z) 3 4 5 6)
                    '(cons 5 (cons 6 null)))
     
     ; ----
     ; 4.2.2 
     
     (make-r6test '(store ()
                     (letrec* ([even?
                                (lambda (n)
                                  (if (eqv? 0 n)
                                      #t
                                      (odd? (- n 1))))]
                               [odd?
                                (lambda (n)
                                  (if (eqv? 0 n)
                                      #f
                                      (even? (- n 1))))])
                       ;; using 88 here runs, but isn't really much more useful
                       ;; for testing purposes (it also takes > 1000 reductions)
                       (even? 2)))
                  (list
                   '(store ((lx-even?
                             (lambda (n)
                               (if (eqv? 0 n)
                                   #t
                                   (lx-odd? (- n 1)))))
                            (lx-odd?
                             (lambda (n)
                               (if (eqv? 0 n)
                                   #f
                                   (lx-even? (- n 1))))))
                      
                      (values #t))))
     
     ; ----
     ; 4.2.3
     (make-r6test '(store () (letrec* ([x 0]) (begin (set! x 5) (+ x 1))))
                  (list '(store ((lx-x 5)) (values 6))))
     
     
     ; ----
     ; 5.2.1
     
     (make-r6test '(store () 
                     (letrec* ([add3 (lambda (x) (+ x 3))])
                       (add3 3)))
                  (list '(store ((lx-add3 (lambda (x) (+ x 3)))) (values 6))))
     (make-r6test '(store () (letrec* ((first car))
                               (first '(1 2))))
                  (list '(store ((lx-first car)) (values 1))))
     
     
     ; ----
     ; 6.1
     
     (make-r6test/v '(eqv? 'a 'a) #t)
     (make-r6test/v '(eqv? 'a 'b) #f)
     (make-r6test/v '(eqv? 2 2) #t)
     (make-r6test/v '(eqv? '() '()) #t)
     (make-r6test/v '(eqv? 100000000 100000000) #t)
     (make-r6test/v '(eqv? (cons 1 2) (cons 1 2)) #f)
     (make-r6test '(store () (eqv? (lambda () 1) (lambda () 2)))
                  (list '(unknown "equivalence of procedures")))
     (make-r6test/v '(eqv? #f 'nil) #f)
     (make-r6test/v '(eqv? #f '()) #f)
     (make-r6test '(store () ((lambda (p) (eqv? p p)) (lambda (x) x)))
                  (list '(unknown "equivalence of procedures")))
     
     (make-r6test 
      '(store () 
         (letrec* ([gen-counter
                    (lambda ()
                      ((lambda (n) 
                         (lambda () (set! n (+ n 1)) n))
                       0))])
                  ((lambda (g) (eqv? g g))
                   (gen-counter))))
      (list '(unknown "equivalence of procedures")))
     
     (make-r6test 
      '(store () 
         (letrec* ((gen-counter
                    (lambda ()
                      ((lambda (n) 
                         (lambda () (set! n (+ n 1)) n))
                       0))))
         (eqv? (gen-counter) (gen-counter))))
      (list '(unknown "equivalence of procedures")))
     
     
     
     ; ----
     ; 6.3.2
     
     (make-r6test '(store ()
                     (letrec* ([x (list 'a 'b 'c)]
                               [y x])
                       y))
                  (list
                   '(store ((lx-x (cons 'a (cons 'b (cons 'c null))))
                            (lx-y (cons 'a (cons 'b (cons 'c null)))))
                      (values (cons 'a (cons 'b (cons 'c null)))))))
     
     (make-r6test '(store ()
                     (letrec* ((x (list 'a 'b 'c))
                               (y x))
                       (set-cdr! x 4)
                       x))
                  (list
                   '(store ((lx-x (cons 'a 4))
                            (lx-y (cons 'a 4)))
                      (values (cons 'a 4)))))
     
     (make-r6test '(store ()
                     (letrec* ((x (list 'a 'b 'c))
                               (y x))
                       (set-cdr! x 4)
                       (eqv? x y)))
                  (list
                   '(store ((lx-x (cons 'a 4))
                            (lx-y (cons 'a 4)))
                      (values #t))))
     
     (make-r6test '(store ()
                     (letrec* ((x (list 'a 'b 'c))
                               (y x))
                       (set-cdr! x 4)
                       y))
                  (list
                   '(store ((lx-x (cons 'a 4))
                            (lx-y (cons 'a 4)))
                      (values (cons 'a 4)))))
     
     ; ----
     ; 6.4
     (make-r6test/v '(apply + (list 3 4)) 7)
     
     (make-r6test
      '(store ()
         (letrec* ([compose
                    (lambda (f g)
                      (lambda args
                        (f (apply g args))))]
                   
                   [sqrt (lambda (x) (if (eqv? x 900) 30 #f))])
           ((compose sqrt *) 12 75)))
      (list '(store ((lx-compose (lambda (f g)
                                   (lambda args
                                     (f (apply g args)))))
                     (lx-sqrt (lambda (x) (if (eqv? x 900) 30 #f))))
               (values 30))))))
  
  (define (conv-base base vec)
    (let loop ([i (vector-length vec)]
               [acc 0])
      (cond
        [(zero? i) acc]
        [else (loop (- i 1)
                    (+ acc (* (expt base (- i 1))
                              (vector-ref vec (- i 1)))))])))
  
  (define (deconv-base base number)
    (list->vector
     (let loop ([i number])
       (cond
         [(zero? i) '()]
         [else (cons (modulo i base)
                     (loop (quotient i base)))]))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; app tests
  ;;
  
  (define app-tests
    (list 
     (make-r6test/v '((lambda () 1)) 1)
     (make-r6test/v '(((lambda (x) (lambda (x) x)) 1) 2) 2)
     (make-r6test/v '(((lambda (x) (lambda (x dot y) x)) 1) 2) 2)
     (make-r6test/v '(((lambda (x) (lambda (y dot x) (car x))) 1) 2 3) 3)
     (make-r6test/e '((lambda (x y) x) 1) "arity mismatch")
     (make-r6test/v '(car ((lambda (x) (cons x null)) 3)) 3)
     (make-r6test/v '((lambda (x) x) 3) 3)
     (make-r6test/v '((lambda (x y) (- x y)) 6 5) 1)
     (make-r6test/e '((lambda () (+ x y z)) 3 4 5)
                    "arity mismatch")
     (make-r6test/v '((lambda (x y z) (+ x y z)) 3 4 5) 12)
     (make-r6test/v '((lambda (x y) (+ x y)) (+ 1 2) (+ 3 4)) 10)
     (make-r6test/v '((lambda (x1 x2 dot y) (car y)) 1 2 3 4) 3)
     (make-r6test/v '((lambda (x dot y) (car y)) 1 2 3 4) 2)
     (make-r6test/v '((lambda (x dot y) x) 1) 1)
     (make-r6test/e '((lambda (x y dot z) x) 1)
                    "arity mismatch")
     (make-r6test/v '((lambda args (car (cdr args))) 1 2 3 4 5 6) 2)
     (make-r6test/v '((lambda args (eqv? args args)) 1 2) #t)
     (make-r6test/v '((lambda args ((lambda (y) args) (begin (set! args 50) 123)))) 50)
     (make-r6test '(store () ((lambda args ((lambda (y) args) (set! args 50)))))
                  (list '(unknown "unspecified result")))
     (make-r6test/v '(if ((lambda (x) x) 74) ((lambda () 6)) (6 54)) 6)
     (make-r6test/e '(1 1) "can't call non-procedure")
     (make-r6test/e '(if ((lambda (x) x) #f) ((lambda () 6)) (6 54))
                    "can't call non-procedure")
     
     (make-r6test '(store () (- 1))
                  (list '(store () (values -1))))
     
     (make-r6test '(store () (- (- 1)))
                  (list '(store () (values 1))))
     
     (make-r6test '(store ((x 1)) (begin (set! x (begin (set! x (- x)) (- x))) x))
                  (list '(store ((x 1)) (values 1))))
     
     (make-r6test '(store ((x 1))
                     ((lambda (p q) x)
                      (begin (set! x (- x)) 1)
                      (begin (set! x (- x)) 1)))
                  (list '(store ((x 1))
                           (values 1))))
     
     (make-r6test '(store ((x 1))
                     ((lambda (p q) 1)
                      (begin (set! x 5) 1)
                      (begin (set! x 6) 2)))
                  (list '(store ((x 5)) (values 1))
                        '(store ((x 6)) (values 1))))
     
     (make-r6test/v '(call/cc
                      (lambda (k)
                        (with-exception-handler
                         (lambda (e) (k e))
                         (lambda () (apply (lambda (x y) x) 1 null)))))
                    '(make-cond "arity mismatch"))
     
     (make-r6test/v '((lambda (x) ((lambda (y) x) (begin (set! x 5) 'whatever))) 3) 5)
     (make-r6test '(store ()
                     (((lambda (a b ret) ((lambda (x y) ret) (begin (set! ret a) #f)
                                                             (begin (set! ret b) #t)))
                       (lambda () 1)
                       (lambda () 3)
                       5)))
                  '((store () (values 1))
                    (store () (values 3))))
     
     (make-r6test/v (let ([Y '(lambda (le)
                                ((lambda (f) (f f))
                                 (lambda (f)
                                   (le (lambda (z) ((f f) z))))))])
                      `((,Y
                         (lambda (length)
                           (lambda (l)
                             (if (null? l)
                                 0
                                 (+ (length (cdr l)) 1)))))
                        (cons 1 null)))
                    1)
     (make-r6test/v '((lambda (x y) (+ x y)) ((lambda (x) x) 3) ((lambda (x) x) 4)) 
                    7)
     (make-r6test/v '((lambda (x) ((lambda (a b) x) (begin (set! x (- x)) 'x)
                                                    (begin (set! x (- x)) 'y))) 
                      1)
                    1)
     
     (make-r6test/v '((lambda (x) (begin (set! x 5) (set! x 4) (set! x 3) x)) 0) 3)
     (make-r6test/v '((lambda (x y) (x y)) + 0) 0)
     (make-r6test/v '(apply + (cons 1 (cons 2 null))) 3)
     (make-r6test '(store ()
                     ((lambda (x) (set-cdr! x x) (apply + x))
                      (cons 1 #f)))
                  (list '(uncaught-exception (make-cond "apply called on circular list"))))
  
     (make-r6test '(store ()
                     ((lambda (x)
                        (set-cdr! (cdr x) x)
                        (apply + x))
                      (cons 1 (cons 2 #f))))
                  (list '(uncaught-exception (make-cond "apply called on circular list"))))
     
     ;; app
     (make-r6test/v '((lambda args (apply + args)) 1 2 3 4) 10)
     (make-r6test/v '((lambda (f) (eqv? (f 1) (f 1))) (lambda args (car args))) #t)
     (make-r6test '(store () 
                     (letrec* ((length
                                (lambda (l)
                                  (if (null? l)
                                      0
                                      (+ 1 (length (cdr l)))))))
                       (length (list 1 2 3))))
                  (list '(store ((lx-length
                                  (lambda (l)
                                    (if (null? l)
                                        0
                                        (+ 1 (lx-length (cdr l)))))))
                           (values 3))))
     (make-r6test '(store () ((lambda (x) 
                                (set! x (x 
                                         (begin (set! x +) 4)
                                         (begin (set! x *) 2)))
                                x)
                              /))
                  (list '(store () (values 2))
                        '(store () (values 6))
                        '(store () (values 8))))
     
     (make-r6test '(store () ((lambda (x) 
                                (set! x (x 
                                         (begin (set! x +) 12)
                                         (begin (set! x *) 2)
                                         (begin (set! x -) 2)))
                                x)
                              /))
                  (list '(store () (values 3))
                        '(store () (values 16))
                        '(store () (values 8))
                        '(store () (values 48))))
     
     (make-r6test '(store () 
                     ((lambda (x) 
                        (set! x (x (begin (set! x *) 2)))
                        x)
                      /))
                  (list '(store () (values 2))
                        '(store () (values 1/2))))
     
     ;; test non-determinism in spec (a single application can go two different ways
     ;; at two different times)
     (make-r6test '(store ()  
                     (letrec ((x null)
                              (twice (lambda (f) (f) (f))))
                       (twice
                        (lambda ()
                          ((lambda (p q) 1)
                           (begin (set! x (cons 1 x)) 'foo)
                           (begin (set! x (cons 2 x)) 'bar))))))
                  (list
                   '(store ((lx-x (cons 1 (cons 2 (cons 1 (cons 2 null)))))
                            (lx-twice (lambda (f) (f) (f))))
                      (values 1))
                   '(store ((lx-x (cons 2 (cons 1 (cons 1 (cons 2 null)))))
                            (lx-twice (lambda (f) (f) (f))))
                      (values 1))
                   '(store ((lx-x (cons 1 (cons 2 (cons 2 (cons 1 null)))))
                            (lx-twice (lambda (f) (f) (f))))
                      (values 1))
                   '(store ((lx-x (cons 2 (cons 1 (cons 2 (cons 1 null)))))
                            (lx-twice (lambda (f) (f) (f))))
                      (values 1))))
     
     (make-r6test/v '(condition? (make-cond "xyz")) #t)
     (make-r6test/v '(condition? 1) #f)
     (make-r6test/v '(procedure?
                      (call/cc
                       (lambda (k)
                         (with-exception-handler k (lambda () (car 'x))))))
                    #f)
     (make-r6test/v '(condition?
                      (call/cc
                       (lambda (k)
                         (with-exception-handler k (lambda () (car 'x))))))
                    #t)
     
     ;; test capture avoiding substitution
     (make-r6test '(store () 
                     (letrec ((x 1))
                       (((lambda (f) (lambda (x) (+ x (f))))
                         (lambda () x))
                        2)))
                  (list '(store ((lx-x 1)) (values 3))))
     
     (make-r6test '(store ()
                     (((lambda (x1) (lambda (x) x))
                       3)
                      4))
                  (list '(store () (values 4))))
     (make-r6test '(store ()
                     (((lambda (x)
                         (lambda args (car args)))
                       1)
                      2))
                  (list '(store () (values 2))))
     
     (make-r6test '(store () 
                     (letrec ((x 1))
                       (((lambda (f) (lambda (y dot x) (f)))
                         (lambda () x))
                        2)))
                  (list '(store ((lx-x 1)) (values 1))))
     
     (make-r6test/v '((lambda (x y dot z) (set! z (cons x z)) (set! z (cons y z)) (apply + z))
                      1 2 3 4)
                    '10)
     
     (make-r6test '(store () 
                     (letrec ((g (lambda (y) y))
                              (f (lambda (x) (g 1))))
                       (((lambda (x) (lambda (g) (g x))) f)
                        (lambda (x) 17))))
                  (list '(store ((lx-g (lambda (y) y))
                                 (lx-f (lambda (x) (lx-g 1))))
                           (values 17))))
     
     (make-r6test '(store () ((lambda (x)
                                (letrec ([x 1]) 
                                  1))
                              1))
                  (list '(store ((lx-x 1)) (values 1))))
     
     (make-r6test '(store () ((lambda (x)
                                (letrec* ([x 1]) 
                                  1))
                              1))
                  (list '(store ((lx-x 1)) (values 1))))
     
     (make-r6test '(store () 
                     (letrec ((x 1))
                       ((lambda (f) (letrec ([x 3]) (f)))
                        (lambda () x))))
                  (list '(store ((lx-x 1) (lx-x1 3)) (values 1))))
     (make-r6test '(store () 
                     (letrec ((x 1))
                       ((lambda (f) (letrec* ([x 3]) (f)))
                        (lambda () x))))
                  (list '(store ((lx-x 1) (lx-x1 3)) (values 1))))))
  
  (define mv-tests
    (list
     (make-r6test
      '(store () ((lambda (x) x) (values (lambda (y) y))))
      (list '(store () (values (lambda (y) y)))))
     (make-r6test
      '(store () (call-with-values (lambda () (lambda (y) y)) (lambda (x) x)))
      (list '(store () (values (lambda (y) y)))))
     (make-r6test
      '(store () (call-with-values 
                  (lambda ()
                    (call-with-values
                     (lambda () ((lambda (z) z) (lambda (q) q)))
                     (lambda (y) y))) 
                  (lambda (x) x)))
      (list '(store () (values (lambda (q) q)))))
     (make-r6test
      '(store () (call-with-values 
                  (lambda ()
                    (call-with-values (lambda () (values (lambda (p) p)))
                                      (((lambda (z) z) (lambda (a) (a a))) (lambda (m) m))))
                  (call-with-values (lambda () (values (lambda (q) q))) (lambda (x) (lambda (y) x)))))
      (list '(store () (values (lambda (q) q)))))
     
     
     (make-r6test
      '(store () ((lambda (x) x) call-with-values))
      (list '(store () (values call-with-values))))
     (make-r6test
      '(store () (values))
      (list '(store () (values))))
     (make-r6test
      '(store () (values (lambda (x) x)))
      (list '(store () (values (lambda (x) x)))))
     (make-r6test
      '(store () (values (lambda (x) x) (lambda (q) q)))
      (list '(store () (values (lambda (x) x) (lambda (q) q)))))
     
     (make-r6test
      '(store () (call-with-values (values values) (lambda () (lambda (x) x))))
      (list '(store () (values (lambda (x) x)))))
     (make-r6test
      '(store () ((lambda (x) x) (values (lambda (y) y))))
      (list '(store () (values (lambda (y) y)))))
     (make-r6test
      '(store () (call-with-values (lambda () (lambda (y) y)) (lambda (x) x)))
      (list '(store () (values (lambda (y) y)))))
     
     (make-r6test
      '(store () 
         (call-with-values 
          (lambda ()
            (call-with-values
             (lambda ()
               ((lambda (z) z) (lambda (q) q)))
             (lambda (y) y)))
          (lambda (x) x)))
      (list '(store () (values (lambda (q) q)))))
     
     (make-r6test
      '(store () 
         (call-with-values 
          (lambda ()
            (call-with-values (lambda ()
                                (values (lambda (p) p)))
                              (((lambda (x) x) (lambda (x) (x x))) (lambda (m) m))))
          (call-with-values (lambda () (values (lambda (q) q))) 
                            (lambda (x) (lambda (y) x)))))
      (list '(store () (values (lambda (q) q)))))
     
     (make-r6test
      '(store () (call-with-values (lambda () (values values values)) call-with-values))
      (list '(store () (values))))
     
     (make-r6test
      '(store () ((lambda (x y) x) (values (lambda (z) z) (lambda (q) q))))
      (list '(unknown "context expected one value, received 2")))
     
     (make-r6test
      '(store () (begin (if #t 1 2) 3))
      (list '(store () (values 3))))
     
     
     (make-r6test
      '(store () ((if (values 1 2 3 4 5 6 7 8 9 10) 11 12)))
      (list '(unknown "context expected one value, received 10")))
     
     
     (make-r6test
      '(store () (if (begin 1 2) 1 2))
      (list '(store () (values 1))))
     
     (make-r6test
      '(store () ((lambda (x) (begin (set! x (begin 1 2)) x)) 1))
      (list '(store () (values 2))))
     
     (make-r6test/v '(call/cc (lambda (k) (cons 1 (cons 2 (cons 3 (k 5)))))) 5)
     (make-r6test/v '(call-with-values (lambda () (call/cc (lambda (k) (k)))) +) 0)
     (make-r6test/v '(call-with-values (lambda () (call/cc (lambda (k) (k 1 2)))) +) 3)
     (make-r6test/v '((call/cc values) values) 'values)
     (make-r6test '(store ()
                     (letrec ((x 0)
                              (f
                               (lambda ()
                                 (set! x (+ x 1))
                                 (values x x))))
                     (call-with-values f (lambda (x y) x))
                     (call-with-values f (lambda (x y) x))))
                  (list
                   '(store ((lx-x 2)
                            (lx-f (lambda ()
                                    (set! lx-x (+ lx-x 1))
                                    (values lx-x lx-x))))
                      (values 2))))
     (make-r6test/v '((lambda (x) (call-with-values x (lambda (x y) x)))
                      (lambda () (values (+ 1 2) 2)))
                    3)
     
     (make-r6test/v '((if #t call-with-values +) (lambda () (+ 1 1)) (lambda (x) x))
                    2)
     
     (make-r6test/v '(call-with-values (lambda () (values (+ 1 2) (+ 2 3))) +) 8)
     (make-r6test/v '(call-with-values * +) 1)
     (make-r6test/v '(call-with-values (lambda () (apply values (cons 1 (cons 2 null)))) +) 3)
     (make-r6test/v '(call-with-values (lambda () 1) +) 1)
     
     (make-r6test/e
      '(call-with-values (lambda ()
                           ((lambda (f) 
                              (f ((lambda (id) id) (lambda (x) (x x)))
                                 (lambda (x y) x)))
                            values))
                         (lambda (a b) (a b)))
      "arity mismatch")
     
     (make-r6test/v '((lambda (x) x) (values 1)) 1)
     (make-r6test '(store () (values 1 2))
                  (list '(store () (values 1 2))))
     (make-r6test '(store () (begin ((lambda (x) (values x x x)) 1) 1))
                  (list '(store () (values 1))))
     (make-r6test '(store () ((lambda (x) (values x x x)) 1))
                  (list '(store () (values 1 1 1))))
     
     (make-r6test/v '(begin (values) 1) 1)
     (make-r6test/v '(+ 1 (begin (values 1 2 3) 1)) 2)))
  
  (define dw-tests
    (list 
     
     ;; an infinite loop that produces a finite (circular) reduction graph
     (make-r6test
      '(store ()
         ((lambda (x) ((call/cc call/cc) x)) (call/cc call/cc)))
      (list))
     
     ;; next examples is one a continuation example that mz gets wrong
     (make-r6test 
      '(store ()
         ((lambda (count)
            ((lambda (first-time? k)
               (if first-time?
                   (begin
                     (set! first-time? #f)
                     (set! count (+ count 1))
                     (k values))
                   1234))
             #t
             (call/cc values))
            count)
          0))
      (list '(store () (values 2))))
     
     (make-r6test
      '(store ([x 2]) x)
      (list '(store ((x 2)) (values 2))))
     (make-r6test
      '(store ([x 2]) (begin (set! x (+ x 1)) x))
      (list '(store ((x 3)) (values 3))))
     
     (make-r6test
      '(store () (begin ((lambda (x) (+ x x)) 1) 2))
      (list '(store () (values 2))))
     
     (make-r6test
      '(store () (+ (call/cc (lambda (k) (+ (k 1) 1))) 1))
      (list '(store () (values 2))))
     (make-r6test
      '(store () ((call/cc (lambda (x) x)) (lambda (y) 1)))
      (list '(store () (values 1))))
     
     (make-r6test
      '(store ((x 0))
         (begin
           (dynamic-wind (lambda () (set! x 1))
                         (lambda () (begin (set! x 2) 'whatever))
                         (lambda () (set! x 3)))
           x))
      (list '(store ((x 3)) (values 3))))
     
     
     (make-r6test
      '(store ((x 0)) (dynamic-wind (lambda () (set! x (+ x 1)))
                                    (lambda () (begin (set! x (+ x 1)) x))
                                    (lambda () (set! x (+ x 1)))))
      (list '(store ((x 3)) (values 2))))
     
     ;; dynamic wind and multiple values
     (make-r6test '(store () (dynamic-wind values (lambda () (values 1 2)) values))
                  (list '(store () (values 1 2))))
     
     ;; dynamic-wind given non-lambda procedure values
     (make-r6test '(store () (dynamic-wind values values values))
                  (list '(store () (values))))
     (make-r6test '(store () (dynamic-wind values (lambda x x) values))
                  (list '(store () (values null))))
     
     
     (make-r6test/e '(dynamic-wind 1 1 1) "dynamic-wind expects procs")
     (make-r6test/e '(dynamic-wind (lambda () (car 'x)) 1 1) "dynamic-wind expects procs")
     
     ;; make sure that dynamic wind signals non-proc errors directly
     ;; instead of calling procedures
     (make-r6test/e '(dynamic-wind (lambda () (car 'x)) 1 2)
                    "dynamic-wind expects procs")
     (make-r6test/e '(dynamic-wind (lambda () (car 1)) (lambda (x) x) (lambda (y) y))
                    "can't take car of non-pair")
     
     (make-r6test/e '(dynamic-wind (lambda () (car 1)) (lambda (x dot y) x) (lambda () 1))
                    "can't take car of non-pair")
     (make-r6test/v '(dynamic-wind + (lambda y 2) *)
                    2)
     (make-r6test/v '(dynamic-wind values list (lambda y y))
                    'null)
     
     
     (make-r6test ; "in thunk isn't really in"
      '(store ((n 0))
         
         (begin
           (call/cc
            (lambda (k)
              (dynamic-wind
               (lambda () (begin
                            (set! n (+ n 1))
                            (k 11)))
               +
               (lambda () (set! n (+ n 1))))))
           n))
      (list '(store ((n 1)) (values 1))))
     
     (make-r6test ; "out thunk is really out"
      '(store ((n 0)
               (do-jump? #t)
               (k-out #f))
         
         (begin
           (call/cc
            (lambda (k)
              (dynamic-wind
               (lambda () (set! n (+ n 1)))
               +
               (lambda ()
                 (begin
                   (set! n (+ n 1))
                   (call/cc (lambda (k) (set! k-out k))))))))
           (if do-jump?
               (begin
                 (set! do-jump? #f)
                 (k-out 0))
               11)
           (set! k-out #f)
           n))
      (list '(store ((n 2) (do-jump? #f) (k-out #f)) (values 2))))
     
     (make-r6test ; "out thunk is really out during trimming"
      '(store ((n 0)
               (do-jump? #t)
               (k-out #f))
         
         (begin
           (call/cc
            (lambda (k)
              (dynamic-wind
               (lambda () (set! n (+ n 1)))
               +
               (lambda ()
                 (begin
                   (set! n (+ n 1))
                   (call/cc (lambda (k) (set! k-out k))))))))
           (if do-jump?
               (begin
                 (set! do-jump? #f)
                 (k-out 0))
               11)
           (set! k-out #f)
           n))
      (list '(store ((n 2) (do-jump? #f) (k-out #f)) (values 2))))
     
     (make-r6test ; "jumping during the results of trimming, pre-thunk"
      '(store ((pre-count 0)
               (pre-jump? #f)
               (after-jump? #t)
               (grab? #t)
               (the-k #f))
         
         (begin
           (dynamic-wind
            (lambda ()
              (begin
                (set! pre-count (+ pre-count 1))
                (if pre-jump?
                    (begin
                      (set! pre-jump? #f)
                      (set! after-jump? #f)
                      (the-k 999))
                    999)))
            (lambda () 
              (if grab?
                  (call/cc
                   (lambda (k)
                     (begin
                       (set! grab? #f)
                       (set! the-k k)
                       'ignoreme)))
                  999))
            +)
           (if after-jump?
               (begin
                 (set! pre-jump? #t)
                 (the-k 999))
               999)
           (set! the-k #f) ;; just to make testing simpler
           pre-count))
      (list '(store ((pre-count 3) (pre-jump? #f) (after-jump? #f) (grab? #f) (the-k #f)) (values 3))))
     
     (make-r6test ; "jumping during the results of trimming, post-thunk"
      '(store ((post-count 0)
               (post-jump? #t)
               (jump-main? #t)
               (grab? #t)
               (the-k #f))
         
         (begin
           (if grab?
               (call/cc
                (lambda (k)
                  (begin
                    (set! grab? #f)
                    (set! the-k k))))
               999)
           (dynamic-wind
            +
            (lambda () 
              (if jump-main?
                  (begin
                    (set! jump-main? #f)
                    (the-k 999))
                  999))
            (lambda () 
              (begin
                (set! post-count (+ post-count 1))
                (if post-jump?
                    (begin
                      (set! post-jump? #f)
                      (the-k 999))
                    999))))
           (set! the-k #f) ;; just to make testing simpler
           post-count))
      (list '(store ((post-count 2) (post-jump? #f) (jump-main? #f) (grab? #f) (the-k #f)) (values 2))))
     
     (make-r6test ; "dynamic-wind gets a continuation"
      '(store () (call/cc (lambda (k) (dynamic-wind + k +))))
      (list '(store () (values))))
     
     #|

to read the following tests, read the argument to conv-base from right to left
each corresponding set! should happen in that order.
in case of a test case failure, turn the number back into a sequence
of digits with deconv-base

|#
     
     (make-r6test ; "hop out one level"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)) 
         
         (begin
           (set! one (lambda () (set! x (+ (* x 2) 0))))
           (set! two (lambda () (call/cc (lambda (k) k))))
           (set! three (lambda () (set! x (+ (* x 2) 1))))
           ((dynamic-wind one two three)
            (lambda (y) x))))
      (list (let ([final-x (conv-base 2 #(1 0 1 0))])
              `(store ((x ,final-x)
                       (one (lambda () (set! x (+ (* x 2) 0))))
                       (two (lambda () (call/cc (lambda (k) k))))
                       (three (lambda () (set! x (+ (* x 2) 1)))))
                 (values ,final-x)))))
     
     (make-r6test ;"hop out two levels"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0))
         
         (begin
           (set! one   (lambda () (set! x (+ (* x 5) 1))))
           (set! two   (lambda () (set! x (+ (* x 5) 2))))
           (set! three (lambda () (set! x (+ (* x 5) 3))))
           (set! four  (lambda () (set! x (+ (* x 5) 4))))
           ((dynamic-wind 
             one
             (lambda () 
               (dynamic-wind
                two
                (lambda () (call/cc (lambda (k) k)))
                three))
             four)
            (lambda (y) x))))
      (list 
       (let ([final-x (conv-base 5 #(4 3 2 1 4 3 2 1))])
         `(store ((x ,final-x)
                  (one   (lambda () (set! x (+ (* x 5) 1))))
                  (two   (lambda () (set! x (+ (* x 5) 2))))
                  (three (lambda () (set! x (+ (* x 5) 3))))
                  (four  (lambda () (set! x (+ (* x 5) 4)))))
            (values ,final-x)))))
     
     (make-r6test ; "don't duplicate tail"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0))
         
         (begin
           (set! one (lambda () (set! x (+ (* x 5) 1))))
           (set! two (lambda () (set! x (+ (* x 5) 2))))
           (set! three (lambda () (set! x (+ (* x 5) 3))))
           (set! four (lambda () (set! x (+ (* x 5) 4))))
           (dynamic-wind 
            one
            (lambda () 
              ((dynamic-wind two
                             (lambda () (call/cc (lambda (k) k)))
                             three)
               (lambda (y) x)))
            four)))
      (list `(store ((x ,(conv-base 5 #(4 3 2 3 2 1)))
                     (one (lambda () (set! x (+ (* x 5) 1))))
                     (two (lambda () (set! x (+ (* x 5) 2))))
                     (three (lambda () (set! x (+ (* x 5) 3))))
                     (four (lambda () (set! x (+ (* x 5) 4)))))
               
               (values ,(conv-base 5 #(3 2 3 2 1))))))
     
     (make-r6test ; "dont' duplicate tail, 2 deep"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0)
               (five 0)
               (six 0))
         
         (begin
           (set! one (lambda () (set! x (+ (* x 7) 1))))
           (set! two (lambda () (set! x (+ (* x 7) 2))))
           (set! three (lambda () (set! x (+ (* x 7) 3))))
           (set! four (lambda () (set! x (+ (* x 7) 4))))
           (set! five (lambda () (set! x (+ (* x 7) 5))))
           (set! six (lambda () (set! x (+ (* x 7) 6))))
           (dynamic-wind 
            one
            (lambda () 
              (dynamic-wind 
               two
               (lambda () 
                 ((dynamic-wind three
                                (lambda () (call/cc (lambda (k) k)))
                                four)
                  (lambda (y) x)))
               five))
            six)))
      
      (list `(store ((x ,(conv-base 7 #(6 5 4 3 4 3 2 1)))
                     (one (lambda () (set! x (+ (* x 7) 1))))
                     (two (lambda () (set! x (+ (* x 7) 2))))
                     (three (lambda () (set! x (+ (* x 7) 3))))
                     (four (lambda () (set! x (+ (* x 7) 4))))
                     (five (lambda () (set! x (+ (* x 7) 5))))
                     (six (lambda () (set! x (+ (* x 7) 6)))))
               (values ,(conv-base 7 #(4 3 4 3 2 1))))))
     
     (make-r6test ; "hop out and back into another one"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0))
         
         (begin
           (set! one (lambda () (set! x (+ (* x 5) 1))))
           (set! two (lambda () (set! x (+ (* x 5) 2))))
           (set! three (lambda () (set! x (+ (* x 5) 3))))
           (set! four (lambda () (set! x (+ (* x 5) 4))))
           ((lambda (ok)
              (dynamic-wind one
                            (lambda () (ok (lambda (y) x)))
                            two))
            (dynamic-wind three
                          (lambda () (call/cc (lambda (k) k)))
                          four))))
      (list `(store ((x ,(conv-base 5 #(2 1 4 3 2 1 4 3)))
                     (one (lambda () (set! x (+ (* x 5) 1))))
                     (two (lambda () (set! x (+ (* x 5) 2))))
                     (three (lambda () (set! x (+ (* x 5) 3))))
                     (four (lambda () (set! x (+ (* x 5) 4)))))
               (values ,(conv-base 5 #(1 4 3 2 1 4 3))))))
     
     (make-r6test ; "hop out one level and back in two levels"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0))
         
         (begin
           (set! one (lambda () (set! x (+ (* x 5) 1))))
           (set! two (lambda () (set! x (+ (* x 5) 2))))
           (set! three (lambda () (set! x (+ (* x 5) 3))))
           (set! four (lambda () (set! x (+ (* x 5) 4))))
           ((lambda (ok)
              (dynamic-wind
               one
               (lambda ()
                 (dynamic-wind
                  two
                  (lambda () (ok (lambda (y) x)))
                  three))
               four))
            (call/cc (lambda (k) k)))))
      (list `(store ((x ,(conv-base 5 #(4 3 2 1 4 3 2 1)))
                     (one (lambda () (set! x (+ (* x 5) 1))))
                     (two (lambda () (set! x (+ (* x 5) 2))))
                     (three (lambda () (set! x (+ (* x 5) 3))))
                     (four (lambda () (set! x (+ (* x 5) 4)))))
               (values ,(conv-base 5 #(2 1 4 3 2 1))))))
     
     (make-r6test ; "hop out two levels and back in two levels"
      '(store ((x 0)
               (one 0)
               (two 0)
               (three 0)
               (four 0)
               (five 0)
               (six 0)
               (seven 0)
               (eight 0))
         
         (begin
           (set! one (lambda () (set! x (+ (* x 9) 1))))
           (set! two (lambda () (set! x (+ (* x 9) 2))))
           (set! three (lambda () (set! x (+ (* x 9) 3))))
           (set! four (lambda () (set! x (+ (* x 9) 4))))
           (set! five (lambda () (set! x (+ (* x 9) 5))))
           (set! six (lambda () (set! x (+ (* x 9) 6))))
           (set! seven (lambda () (set! x (+ (* x 9) 7))))
           (set! eight (lambda () (set! x (+ (* x 9) 8))))
           ((lambda (ok)
              (dynamic-wind
               one
               (lambda () 
                 (dynamic-wind
                  two
                  (lambda () (ok (lambda (y) x)))
                  three))
               four))
            (dynamic-wind
             five
             (lambda () 
               (dynamic-wind
                six
                (lambda () (call/cc (lambda (k) k)))
                seven))
             eight))))
      (list `(store ((x ,(conv-base 9 #(4 3 2 1 8 7 6 5 4 3 2 1 8 7 6 5)))
                     (one (lambda () (set! x (+ (* x 9) 1))))
                     (two (lambda () (set! x (+ (* x 9) 2))))
                     (three (lambda () (set! x (+ (* x 9) 3))))
                     (four (lambda () (set! x (+ (* x 9) 4))))
                     (five (lambda () (set! x (+ (* x 9) 5))))
                     (six (lambda () (set! x (+ (* x 9) 6))))
                     (seven (lambda () (set! x (+ (* x 9) 7))))
                     (eight (lambda () (set! x (+ (* x 9) 8)))))
               (values ,(conv-base 9 #(2 1 8 7 6 5 4 3 2 1 8 7 6 5))))))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; exception tests
  ;;
  
  (define exn-tests
    (list
     (make-r6test/v '(with-exception-handler (lambda (x) 1) (lambda () 2))
                    2)
     (make-r6test/v '(with-exception-handler (lambda (x) 1) (lambda () (raise-continuable 2)))
                    1)
     (make-r6test/v '(with-exception-handler (lambda (x) x) (lambda () (raise-continuable 2)))
                    2)
     (make-r6test/v '(with-exception-handler values (lambda () (raise-continuable 2)))
                    2)
     (make-r6test '(store () (with-exception-handler (lambda (x) x) values))
                  (list '(store () (values))))
     (make-r6test '(store () (with-exception-handler (lambda (x) (values x x)) (lambda () (raise-continuable 1))))
                  (list '(store () (values 1 1))))
     (make-r6test/v '(+ 1 (with-exception-handler
                           (lambda (x) (+ 2 x))
                           (lambda () (+ 3 (raise-continuable (+ 2 2))))))
                    10)
     
     (make-r6test '(store ()
                     (call/cc
                      (lambda (k)
                        (with-exception-handler
                         (lambda (x)
                           (with-exception-handler
                            (lambda (y) (k (eqv? x y)))
                            (lambda () (car 1))))
                         (lambda () (car 1))))))
                  (list '(store () (values #t))
                        '(store () (values #f))))
     
     ;; nested handlers
     (make-r6test/v '(with-exception-handler
                      (lambda (x) (+ 2 x))
                      (lambda ()
                        (with-exception-handler
                         (lambda (x) (+ 3 x))
                         (lambda () (raise-continuable 1)))))
                    4)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (y) (with-exception-handler
                                   (lambda (x) (+ 3 x y))
                                   (lambda () (raise-continuable 1))))
                      (lambda () (raise-continuable 17)))
                    21)
     
     (make-r6test/v '(with-exception-handler
                      values
                      (lambda ()
                        (with-exception-handler
                         (lambda (y) (raise-continuable y))
                         (lambda () (raise-continuable 1)))))
                    1)
     
     (make-r6test '(store ()
                     (with-exception-handler 
                      (lambda (y) (raise-continuable y))
                      (lambda () (raise 2))))
                  (list '(uncaught-exception 2)))
     
     (make-r6test '(store ()
                     (with-exception-handler 
                      (lambda (y) (raise y))
                      (lambda () (raise-continuable 2))))
                  (list '(uncaught-exception 2)))
     
     (make-r6test '(store () (raise 2))
                  (list '(uncaught-exception 2)))
     
     (make-r6test '(store () (raise-continuable 2))
                  (list '(uncaught-exception 2)))
     
     (make-r6test '(store () (letrec* ([w 3]
                                       [x (+ 1 (raise-continuable 2))]
                                       [y 2])
                               1))
                  (list '(uncaught-exception 2)))
     
     (make-r6test '(store ()
                     (with-exception-handler
                      (lambda (x) x)
                      (lambda () (raise 2))))
                  (list '(uncaught-exception (make-cond "handler returned"))))
     
     (make-r6test/e '((lambda (c e)
                        (with-exception-handler
                         (lambda (x) (if (eqv? c 0)
                                         (set! c 1)
                                         (if (eqv? c 1)
                                             (begin (set! c 2)
                                                    (set! e x))
                                             (raise e))))
                         (lambda () (raise 2))))
                      0 #f)
                    "handler returned")
     
     (make-r6test/v '(call/cc 
                      (lambda (k) 
                        (with-exception-handler 
                         (lambda (x) (k (eqv? x 2)))
                         (lambda () (car 1)))))
                    #f)
     
     (make-r6test/v '((lambda (sx first-time?)
                        ((lambda (k)
                           (if first-time?
                               (begin
                                 (set! first-time? #f)
                                 (with-exception-handler
                                  (lambda (x) (k values))
                                  (lambda ()
                                    (dynamic-wind
                                     +
                                     (lambda () (raise-continuable 1))
                                     (lambda () (set! sx (+ sx 1)))))))
                               sx))
                         (call/cc values)))
                      1 #t)
                    2)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (x) (begin (set! x (+ x 1)) x))
                      (lambda ()
                        (raise-continuable 1)))
                    2)
     
     (make-r6test/v '(call/cc
                      (lambda (k)
                        (with-exception-handler
                         (lambda (x) (set! x (+ x 1)) (k x))
                         (lambda ()
                           (raise 1)))))
                    2)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (x) 2)
                      (lambda ()
                        (dynamic-wind
                         +
                         (lambda () (raise-continuable 1))
                         +)))
                    2)
     
     (make-r6test '(store ()
                     (with-exception-handler
                      (lambda (x) (raise (+ x 1)))
                      (lambda ()
                        (dynamic-wind
                         +
                         (lambda () (raise 1))
                         +))))
                  (list '(uncaught-exception 2)))
     
     (make-r6test/v '(with-exception-handler
                      (lambda (x) x)
                      (lambda ()
                        (dynamic-wind
                         +
                         (lambda () (raise-continuable 1))
                         +)))
                    1)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (x) (begin (set! x 2) x))
                      (lambda ()
                        (dynamic-wind
                         +
                         (lambda () (raise-continuable 1))
                         +)))
                    2)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (x) (with-exception-handler
                                   (lambda (x) x)
                                   (lambda () (raise-continuable 1))))
                      (lambda () (raise-continuable 2)))
                    1)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (y) 
                        (with-exception-handler
                         (lambda (x) y)
                         (lambda ()
                           (raise-continuable 1))))
                      (lambda ()
                        (raise-continuable 2)))
                    2)
     
     (make-r6test/v '(with-exception-handler
                      (lambda (y) 
                        (with-exception-handler
                         (lambda (x) x)
                         (lambda ()
                           (raise-continuable 1))))
                      (lambda ()
                        (raise-continuable 2)))
                    1)
     
     (make-r6test/e '(with-exception-handler 2 +)
                    "with-exception-handler expects procs")
     (make-r6test/e '(with-exception-handler + 2)
                    "with-exception-handler expects procs")
     (make-r6test/e '(with-exception-handler 1 2)
                    "with-exception-handler expects procs")
     (make-r6test/v '(with-exception-handler (lambda (wrench crowbar) wrench) (lambda () 1))
                    1)
     (make-r6test/e '(with-exception-handler (lambda (wrench crowbar) wrench) (lambda () (raise 1)))
                    "arity mismatch")
     (make-r6test/e '(with-exception-handler 3 (lambda () 1))
                    "with-exception-handler expects procs")
     
     (make-r6test/v '((lambda (y)
                        (with-exception-handler
                         (lambda (x) (set! y (+ x y)))
                         (lambda ()
                           (raise-continuable 1)
                           (raise-continuable 2)
                           y)))
                      0)
                    3)
     
     (make-r6test '(store ()
                     (with-exception-handler
                      (lambda (x) (raise x))
                      (lambda () (raise 1))))
                  (list '(uncaught-exception 1)))
     
     ;; make sure that the inner handler is called twice, 
     ;; rather than the inner handler called once and the outer one called once.
     (make-r6test/v '((lambda (o)
                        (with-exception-handler
                         (lambda (x) (set! o (* 3 o)))
                         (lambda ()
                           (with-exception-handler
                            (lambda (x) (set! o (* 2 o)) x)
                            (lambda () 
                              (raise-continuable 4)
                              (raise-continuable 4)))))
                        o)
                      1)
                    4)
     
     (make-r6test 
      '(store ()
         (letrec* ([k #f]
                   [ans #f]
                   [first-time? #t])
           (with-exception-handler
            (lambda (x)
              (begin
                (call/cc (lambda (k2) (set! k k2)))
                (set! x (+ x 1))
                (set! ans x)))
            (lambda ()
              (raise-continuable 1)))
           (if first-time?
               (begin
                 (set! first-time? #f)
                 (k 1))
               (set! k #f))
           ans))
      (list '(store ((lx-k #f) (lx-ans 3) (lx-first-time? #f))
               (values 3))))
     
     ;; test trimming function in the presence of exceptions when trimming handlers
     ;; this test belongs in the dw section. have to move it there after changing its syntax
     (make-r6test '(store ()
                     (letrec* ((phase 0)
                               (k #f)
                               (l '()))
                       (with-exception-handler
                        (lambda (x) (if (eqv? phase 0)
                                        (begin
                                          (set! phase 1)
                                          (call/cc (lambda (k2) (begin (set! k k2) 'whatever))))
                                        (if (eqv? phase 1)
                                            (begin
                                              (set! phase 2)
                                              (k 1))
                                            1234)))
                        (lambda ()
                          (dynamic-wind 
                           (lambda () (set! l (cons 1 l)))
                           (lambda () 
                             (dynamic-wind 
                              (lambda () (set! l (cons 2 l)))
                              (lambda () (raise-continuable 1))
                              (lambda () (set! l (cons 3 l))))
                             (dynamic-wind 
                              (lambda () (set! l (cons 4 l)))
                              (lambda () (raise-continuable 1))
                              (lambda () (set! l (cons 5 l)))))
                           (lambda () (set! l (cons 6 l))))))
                       (set! k #f)
                       (apply values l)))
                  (list '(store ((lx-phase 2) 
                                 (lx-k #f)
                                 (lx-l (cons 6 (cons 5 (cons 4 (cons 3 (cons 2 (cons 5 (cons 4 (cons 3 (cons 2 (cons 1 null))))))))))))
                           (values 6 5 4 3 2 5 4 3 2 1))))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; letrec tests
  ;;
  
  (define letrec-tests
    (list 
     (make-r6test '(store () (letrec ([x 1] [y 2]) (+ x y)))
                  (list '(store ((lx-x 1) (lx-y 2)) (values 3))))
     (make-r6test '(store ()
                     (letrec ([flip (lambda (x) (if x (flop #f) #t))]
                              [flop (lambda (x) (if x (flip x) x))])
                       (begin0 (flop #t)
                               (set! flip 1)
                               (set! flop 2))))
                  (list '(store ((lx-flip 1)
                                 (lx-flop 2))
                           (values #f))))
     (make-r6test '(store () (letrec ([x (begin (set! x 1) 2)]) x))
                  (list '(store ((lx-x 2)) (values 2))
                        '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store ()
                     (letrec ([x (begin (set! y 2) 5)]
                              [y (begin (set! x 3) 7)])
                       (* x y)))
                  (list '(store ((lx-x 5) (lx-y 7)) (values 35))
                        '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec ([x x]) x))
                  (list '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec ([x y] [y x]) x))
                  (list '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec ([x 1] [y x]) y))
                  (list '(uncaught-exception (make-cond "letrec variable touched"))))
     
     (make-r6test '(store () (letrec ([x 1] [y 2]) (set! x 3) (set! y 4) (+ x y)))
                  (list '(store ((lx-x 3) (lx-y 4)) (values 7))))
     
     (make-r6test '(store () (letrec* ([x 1] [y 2]) (+ x y)))
                  (list '(store ((lx-x 1) (lx-y 2)) (values 3))))
     (make-r6test '(store ()
                     (letrec* ([flip (lambda (x) (if x (flop #f) #t))]
                               [flop (lambda (x) (if x (flip x) x))])
                              (begin0 (flop #t)
                                      (set! flip 1)
                                      (set! flop 2))))
                  (list '(store ((lx-flip 1) (lx-flop 2)) (values #f))))
     (make-r6test '(store () (letrec* ([x (begin (set! x 1) 2)]) x))
                  (list '(store ((lx-x 2)) (values 2))
                        '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store ()
                     (letrec* ([x (begin (set! y 2) 5)]
                               [y (begin (set! x 3) 7)])
                              (* x y)))
                  (list '(store ((lx-x 3) (lx-y 7)) (values 21))
                        '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec* ([x x]) x))
                  (list '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec* ([x y] [y x]) x))
                  (list '(uncaught-exception (make-cond "letrec variable touched"))))
     (make-r6test '(store () (letrec* ([x 1] [y x]) y))
                  (list '(store ((lx-x 1) (lx-y 1)) (values 1))))
     
     (make-r6test '(store () ((lambda (x y) (letrec ([q (begin (set! x 2) 23)]) (begin (set! y 3) (* x y))))
                              5 7))
                  (list '(store ((lx-q 23)) (values 6))))
     (make-r6test '(store () ((lambda (x y) (letrec* ([q (begin (set! x 2) 23)]) (begin (set! y 3) (* x y))))
                              5 7))
                  (list '(store ((lx-q 23)) (values 6))))
     (make-r6test '(store () (letrec* ([x 1] [y 2]) (set! x 3) (set! y 4) (+ x y)))
                  (list '(store ((lx-x 3) (lx-y 4)) (values 7))))
     
     
     (make-r6test '(store ()
                     (letrec* ([k (call/cc (lambda (x) x))])
                       (k (lambda (x) x))
                       (k 2)))
                  (list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
                        '(store ((lx-k (lambda (x) x))) (values 2))))
     (make-r6test '(store ()
                     (letrec ([k (call/cc (lambda (x) x))])
                       (k (lambda (x) x))
                       (k 2)))
                  (list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
                        '(store ((lx-k (lambda (x3) x3))) (values 2))))
     
     (make-r6test '(store ()
                     ((lambda (flag)
                        (letrec* ([k
                                   ((lambda (k)
                                      (if flag
                                          'nothing-doing
                                          (car 'not-a-pair))
                                      k) 
                                    (call/cc (lambda (x) x)))])
                          (set! flag #f)
                          (k (lambda (x) x))
                          (k 2)))
                      #t))
                  (list '(uncaught-exception (make-cond "can't take car of non-pair"))))
     (make-r6test '(store ()
                     ((lambda (flag)
                        (letrec ([k
                                  ((lambda (k)
                                     (if flag
                                         'nothing-doing
                                         (car 'not-a-pair))
                                     k) 
                                   (call/cc (lambda (x) x)))])
                          (set! flag #f)
                          (k (lambda (x) x))
                          (k 2)))
                      #t))
                  (list '(uncaught-exception (make-cond "can't take car of non-pair"))))
     
     
     (make-r6test '(store ()
                     ((lambda (flag)
                        (letrec ([k (call/cc (lambda (x) x))]
                                 [x (if flag
                                        'nothing-doing
                                        (car 'not-a-pair))])
                          (set! flag #f)
                          (k (lambda (x) x))
                          (k 2)))
                      #t))
                  (list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
                        '(uncaught-exception (make-cond "can't take car of non-pair"))
                        '(store ((lx-k (lambda (x3) x3)) (lx-x 'nothing-doing)) (values 2))))
     
     (make-r6test '(store ()
                     ((lambda (flag)
                        (letrec* ([k (call/cc (lambda (x) x))]
                                  [x (if flag
                                         'nothing-doing
                                         (car 'not-a-pair))])
                          (set! flag #f)
                          (k (lambda (x) x))
                          (k 2)))
                      #t))
                  (list '(uncaught-exception (make-cond "reinvoked continuation of letrec init"))
                        '(uncaught-exception (make-cond "can't take car of non-pair"))))
     
     (make-r6test '(store ()
                     (letrec* ([x (values 1 2)])
                       x))
                  (list '(unknown "context expected one value, received 2")))
     (make-r6test '(store ()
                     (letrec ([x (values 1 2)])
                       x))
                  (list '(unknown "context expected one value, received 2")))))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; testing functions
  ;;
  
  
  (define-syntax (test-fn stx)
    (syntax-case stx ()
      [(_ test-case expected)
       (with-syntax ([line (syntax-line stx)])
         (syntax (test-fn/proc (λ () test-case) expected line)))]))
  
  (define (test-fn/proc tc expected line)
    (let ([got (tc)])
      (unless (equal? got expected)
        (set! failed-tests (+ failed-tests 1))
        (fprintf (current-error-port)
                 "line ~s failed\nexpected ~s\n     got ~s\n"
                 line
                 expected
                 got))))
  
  
  (define (test-fns)
    (begin
      (test-fn (term (Var-set!d? (x (set! x 1)))) #t)
      (test-fn (term (Var-set!d? (x (set! y 1)))) #f)
      (test-fn (term (Var-set!d? (x (lambda (x) (set! x 2))))) #f)
      (test-fn (term (Var-set!d? (x (lambda (z dot x) (set! x 2))))) #f)
      (test-fn (term (Var-set!d? (x (lambda (x dot z) (set! x 2))))) #f)
      (test-fn (term (Var-set!d? (x (lambda (y) (set! x 2))))) #t)
      (test-fn (term (Var-set!d? (x 
                                  (if (begin (set! x 2))
                                      1
                                      2))))
               #t)
      (test-fn (term (Var-set!d? (x (begin0 (begin (begin0 1 2) 3) 4))))
               #f)
      (test-fn (term (Var-set!d? (x (dw x1 1 2 3)))) #f)
      (test-fn (term (Var-set!d? (y (throw x ((set! x 2)))))) #f)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; all of the tests
  ;;
  
  (define the-sets 
    (list (list "app" app-tests)
          (list "exn" exn-tests)
          (list "dw" dw-tests)
          (list "eqv" eqv-tests)
          (list "r5" r5-tests)
          (list "mv" mv-tests)
          (list "letrec" letrec-tests)
          (list "unspec" assignment-results-tests)
          (list "quote" quote-tests)
          (list "arith" arithmetic-tests)
          (list "basic" basic-form-tests)
          (list "pair" pair-tests)
          (list "err" err-tests)))
  
  (define the-tests (apply append (map cadr the-sets)))
  
  (define main
    (opt-lambda ([verbose? #f])
      (time
       (let ()
         (define first? #t)
         (define (run-a-set name set)
           (unless first?
             (if verbose?
                 (printf "\n\n")
                 (printf "\n")))
           (if verbose?
               (printf "~a\n~a tests\n\n" 
                       (apply string (build-list 60 (λ (i) #\-)))
                       name)
               (begin (printf "~a tests " name)
                      (flush-output)))
           (set! first? #f)
           (for-each (λ (x) (run-a-test x verbose?)) set))
         
         (set! failed-tests 0)
         (set! verified-terms 0)
         (test-fns)
         (for-each (λ (set) (apply run-a-set set)) the-sets)
         (unless verbose? (printf "\n"))
         
         (if (= 0 failed-tests)
             (printf "~a tests, all passed\n" test-count)
             (printf "~a tests, ~a tests failed\n" test-count failed-tests))
         (printf "verified that ~a terms are p*\n" verified-terms)))
      (collect-garbage) (collect-garbage) (collect-garbage)
      (printf "mem ~s\n" (current-memory-use))))
  
  (provide main
           the-tests
           
           ;; the 'test' and the 'expected' are not compared with equal?.
           ;; instead, the result of running the test is first simplified
           ;; by substituting all of the variables with a colon in their
           ;; names thru the term, and then the results from the test are
           ;; compared with equal? to the elements of `expected'
           (struct r6test (test            ;; p (from the r6 grammar) [the test]
                           expected))))    ;; (list-of p)