
(if (not (defined? 'SECTION))
    (load-relative "testing.ss"))

(test '() 'null null)
(test '() 'null ())

(let ([f (lambda () #&7)])
  (test #t eq? (f) (f)))

(SECTION 2 1);; test that all symbol characters are supported.
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)

(SECTION 3 4)
(define disjoint-type-functions
  (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
  (list
   #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
(define i 1)
(for-each (lambda (x) (display (make-string i #\ ))
		  (set! i (+ 3 i))
		  (write x)
		  (newline))
	  disjoint-type-functions)
(define type-matrix
  (map (lambda (x)
	 (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
	   (write t)
	   (write x)
	   (newline)
	   t))
       type-examples))

(SECTION 6 1)
(test #f not #t)
(test #f not 3)
(test #f not (list 3))
(test #t not #f)
(test #f not '())
(test #f not (list))
(test #f not 'nil)
(arity-test not 1 1)

(test #t boolean? #f)
(test #t boolean? #t)
(test #f boolean? 0)
(test #f boolean? '())
(arity-test boolean? 1 1)

(SECTION 6 2)
(test #t eqv? 'a 'a)
(test #f eqv? 'a 'b)
(test #t eqv? 2 2)
(test #f eqv? 2 2.0)
(test #t eqv? '() '())
(test #t eqv? '10000 '10000)
(test #t eqv? 10000000000000000000 10000000000000000000)
(test #f eqv? 10000000000000000000 10000000000000000001)
(test #f eqv? 10000000000000000000 20000000000000000000)
(test #f eqv? (cons 1 2) (cons 1 2))
(test #f eqv? (lambda () 1) (lambda () 2))
(test #f eqv? #f 'nil)
(let ((p (lambda (x) x)))
  (test #t eqv? p p))
(define gen-counter
 (lambda ()
   (let ((n 0))
      (lambda () (set! n (+ n 1)) n))))
(let ((g (gen-counter))) (test #t eqv? g g))
(test #f eqv? (gen-counter) (gen-counter))
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
	 (g (lambda () (if (eqv? f g) 'g 'both))))
  (test #f eqv? f g))

(test #t eq? 'a 'a)
(test #f eq? (list 'a) (list 'a))
(test #t eq? '() '())
(test #t eq? car car)
(let ((x '(a))) (test #t eq? x x))
(let ((x '#())) (test #t eq? x x))
(let ((x (lambda (x) x))) (test #t eq? x x))

(test #t equal? 'a 'a)
(test #t equal? '("a") '("a"))
(test #t equal? '(a) '(a))
(test #t equal? '(a (b) c) '(a (b) c))
(test #t equal? '("a" ("b") "c") '("a" ("b") "c"))
(test #t equal? "abc" "abc")
(test #t equal? 2 2)
(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
(test #t equal? (box "a") (box "a"))
(test #f equal? "" (string #\null))

(test #f equal? 'a "a")
(test #f equal? 'a 'b)
(test #f equal? '(a) '(b))
(test #f equal? '(a (b) d) '(a (b) c))
(test #f equal? '(a (b) c) '(d (b) c))
(test #f equal? '(a (b) c) '(a (d) c))
(test #f equal? "abc" "abcd")
(test #f equal? "abcd" "abc")
(test #f equal? 2 3)
(test #f equal? 2.0 2)
(test #f equal? (make-vector 5 'b) (make-vector 5 'a))
(test #f equal? (box "a") (box "b"))

(arity-test eq? 2 2)
(arity-test eqv? 2 2)
(arity-test equal? 2 2)

(SECTION 6 3)
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
(define x (list 'a 'b 'c))
(define y x)
(and list? (test #t list? y))
(set-cdr! x 4)
(test '(a . 4) 'set-cdr! x)
(test #t eqv? x y)
(test '(a b c . d) 'dot '(a . (b . (c . d))))
(test #f list? y)
(let ((x (list 'a))) (set-cdr! x x) (test #f list? x))
(arity-test list? 1 1)

(test #t pair? '(a . b))
(test #t pair? '(a . 1))
(test #t pair? '(a b c))
(test #f pair? '())
(test #f pair? '#(a b))
(arity-test pair? 1 1)

(test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c))
(test '(a . 3) cons 'a 3)
(test '((a b) . c) cons '(a b) 'c)
(arity-test cons 2 2) 

(test 'a car '(a b c))
(test '(a) car '((a) b c d))
(test 1 car '(1 . 2))
(arity-test car 1 1)
(error-test '(car 1))

(test '(b c d) cdr '((a) b c d))
(test 2 cdr '(1 . 2))
(arity-test cdr 1 1)
(error-test '(cdr 1))

(test '(a 7 c) list 'a (+ 3 4) 'c)
(test '() list)

(test 3 length '(a b c))
(test 3 length '(a (b) (c d e)))
(test 0 length '())
(arity-test length 1 1)
(error-test '(length 1))
(error-test '(length '(1 . 2)))
(error-test '(length "a"))
; (error-test '(length (quote #0=(1 . #0#))))
(error-test '(let ([p (cons 1 1)]) (set-cdr! p p) (length p)))
(define x (cons 4 0))
(set-cdr! x x) 
(error-test '(length x))

(define l '(1 2 3))
(set-cdr! l 5)
(test '(1 . 5) 'set-cdr! l)
(set-car! l 0)
(test '(0 . 5) 'set-car! l)
(arity-test set-car! 2 2)
(arity-test set-cdr! 2 2)
(error-test '(set-car! 4 4))
(error-test '(set-cdr! 4 4))

(define (box-tests box unbox box? set-box! set-box!-name unbox-name)
  (define b (box 5))
  (test 5 unbox b)
  (when set-box!
	(set-box! b 6)
	(test 6 unbox b))
  (test #t box? b)
  (test #f box? 5)
  (arity-test box 1 1)
  (arity-test unbox 1 1)
  (arity-test box? 1 1)
  (when set-box!
	(arity-test set-box! 2 2))
  (error-test `(,unbox-name 8))
  (when set-box!
	(error-test `(,set-box!-name 8 8))))
(box-tests box unbox box? set-box! 'set-box! 'unbox)
(box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value)

(test '(x y) append '(x) '(y))
(test '(a b c d) append '(a) '(b c d))
(test '(a (b) (c)) append '(a (b)) '((c)))
(test '() append)
(test '(a b c . d) append '(a b) '(c . d))
(test 'a append '() 'a)
(test 1 append 1)
(test '(1 . 2) append '(1) 2)
(test '(1 . 2) append '(1) 2)
(error-test '(append '(1 2 . 3) 1))
(error-test '(append '(1 2 3) 1 '(4 5 6)))
(test '(x y) append! '(x) '(y))
(test '(a b c d) append! '(a) '(b c d))
(test '(a (b) (c)) append! '(a (b)) '((c)))
(test '() append!)
(test '(a b c . d) append! '(a b) '(c . d))
(test 'a append! '() 'a)
(test 1 append! 1)
(error-test '(append! '(1 2 . 3) 1))
(error-test '(append! '(1 2 3) 1 '(4 5 6)))

(define l '(1 2))
(define l2 '(3 4 . 7))
(define l3 (append l l2))
(test '(1 2 3 4 . 7) 'append l3)
(set-car! l2 5)
(test '(1 2 5 4 . 7) 'append l3)
(set-car! l3 0)
(test '(0 2 5 4 . 7) 'append l3)
(test '(1 2) 'append l)

(let* ([l '(1 2)]
       [l2 '(3 4 . 7)]
       [l3 (append! l l2)])
  (test '(1 2 3 4 . 7) 'append! l3)
  (set-car! l2 5)
  (test '(1 2 5 4 . 7) 'append! l3)
  (set-car! l3 0)
  (test '(0 2 5 4 . 7) 'append! l3)
  (test '(0 2 5 4 . 7) 'append! l))

(test '(c b a) reverse '(a b c))
(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
(arity-test reverse 1 1)
(error-test '(reverse 1))
(error-test '(reverse '(1 . 1)))

(define l '(a b c))
(test '(c b a) reverse! l)
(test '(a) 'reverse! l)
(test '((e (f)) d (b c) a) reverse! '(a (b c) d (e (f))))
(arity-test reverse! 1 1)
(error-test '(reverse! 1))
(error-test '(reverse! '(1 . 1)))

(test 'c list-ref '(a b c d) 2)
(test 'c list-ref '(a b c . d) 2)
(arity-test list-ref 2 2)
(error-test '(list-ref 1 1) exn:application:mismatch?)
(error-test '(list-ref '(a b . c) 2) exn:application:mismatch?)
(error-test '(list-ref '(1 2 3) 2.0))
(error-test '(list-ref '(1) '(1)))
(error-test '(list-ref '(1) 1) exn:application:mismatch?)
(error-test '(list-ref '() 0) exn:application:mismatch?)
(error-test '(list-ref '() 0) exn:application:mismatch?)
(error-test '(list-ref '(1) -1))

(test '(c d) list-tail '(a b c d) 2)
(test '(a b c d) list-tail '(a b c d) 0)
(test '(b c . d) list-tail '(a b c . d) 1)
(test 1 list-tail 1 0)
(arity-test list-tail 2 2)
(error-test '(list-tail 1 1) exn:application:mismatch?)
(error-test '(list-tail '(1 2 3) 2.0))
(error-test '(list-tail '(1) '(1)))
(error-test '(list-tail '(1) -1))
(error-test '(list-tail '(1) 2) exn:application:mismatch?)
(error-test '(list-tail '(1 2 . 3) 3) exn:application:mismatch?)

(define (test-mem memq memq-name)
  (test '(a b c) memq 'a '(a b c))
  (test '(b c) memq 'b '(a b c))
  (test '(b . c) memq 'b '(a b . c))
  (test '#f memq 'a '(b c d))

  (arity-test memq 2 2)
  (error-test `(,memq-name 'a 1)  exn:application:mismatch?)
  (error-test `(,memq-name 'a '(1 . 2)) exn:application:mismatch?))

(test-mem memq 'memq)
(test-mem memv 'memv)
(test-mem member 'member)

(test #f memq "apple" '("apple"))
(test #f memv "apple" '("apple"))
(test '("apple") member "apple" '("apple"))

; (test #f memq 1/2 '(1/2)) ; rationals are immutable and we may want to optimize
(test '(1/2) memv 1/2 '(1/2))
(test '(1/2) member 1/2 '(1/2))

(test '((1 2)) member '(1 2) '(1 2 (1 2)))

(define (test-ass assq assq-name)
  (define e '((a 1) (b 2) (c 3)))
  (test '(a 1) assq 'a e)
  (test '(b 2) assq 'b e)
  (test #f assq 'd e)
  (test '(a 1) assq 'a '((x 0) (a 1) b 2))
  (test '(a 1) assq 'a '((x 0) (a 1) . 0))
  (arity-test assq 2 2)

  (error-test `(,assq-name 1 1) exn:application:mismatch?)
  (error-test `(,assq-name 1 '(1 2))  exn:application:mismatch?)
  (error-test `(,assq-name 1 '((0) . 2)) exn:application:mismatch?))

(test-ass assq 'assq)
(test-ass assv 'assv)
(test-ass assoc 'assoc)

(test #f assq '(a) '(((a)) ((b)) ((c))))
(test #f assv '(a) '(((a)) ((b)) ((c))))
(test '((b) 1) assoc '(b) '(((a)) ((b) 1) ((c))))

; (test #f assq '1/2 '(((a)) (1/2) ((c)))) ; rationals are immutable and we may want to optimize
(test '(1/2) assv '1/2 '(((a)) (1/2) ((c))))
(test '(1/2) assoc '1/2 '(((a)) (1/2) ((c))))

(SECTION 6 4)
(test #t symbol? 'foo)
(test #t symbol? (car '(a b)))
(test #f symbol? "bar")
(test #t symbol? 'nil)
(test #f symbol? '())
(test #f symbol? #f)
;;; But first, what case are symbols in?  Determine the standard case:
(define char-standard-case char-upcase)
(if (string=? (symbol->string 'A) "a")
    (set! char-standard-case char-downcase))
(test #t 'standard-case
      (string=? (symbol->string 'a) (symbol->string 'A)))
(test #t 'standard-case
      (or (string=? (symbol->string 'a) "A")
	  (string=? (symbol->string 'A) "a")))
(define (str-copy s)
  (let ((v (make-string (string-length s))))
    (do ((i (- (string-length v) 1) (- i 1)))
	((< i 0) v)
      (string-set! v i (string-ref s i)))))
(define (string-standard-case s)
  (set! s (str-copy s))
  (do ((i 0 (+ 1 i))
       (sl (string-length s)))
      ((>= i sl) s)
      (string-set! s i (char-standard-case (string-ref s i)))))
(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
(test (string-standard-case "martin") symbol->string 'Martin)
(test "Malvina" symbol->string (string->symbol "Malvina"))
(test #t 'standard-case (eq? 'a 'A))

(define x (string #\a #\b))
(define y (string->symbol x))
(string-set! x 0 #\c)
(test "cb" 'string-set! x)
(test "ab" symbol->string y)
(test y string->symbol "ab")

(test #t eq? 'mISSISSIppi 'mississippi)
(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
(test 'JollyWog string->symbol (symbol->string 'JollyWog))

(arity-test symbol? 1 1)

(SECTION 6 6)
(test #t eqv? '#\  #\Space)
(test #t eqv? #\space '#\Space)
(test #t char? #\a)
(test #t char? #\()
(test #t char? #\ )
(test #t char? '#\newline)
(arity-test char? 1 1)

(test #t char=? #\A)
(test #f char=? #\A #\B)
(test #f char=? #\A #\A #\B)
(test #f char=? #\A #\B #\A)
(test #f char=? #\a #\b)
(test #f char=? #\9 #\0)
(test #t char=? #\A #\A)
(test #t char=? #\A #\A #\A)
(test #t char=? #\370 #\370)
(test #f char=? #\371 #\370)
(test #f char=? #\370 #\371)
(arity-test char=? 1 -1)
(error-test '(char=? #\a 1)) 
(error-test '(char=? #\a #\b 1)) 
(error-test '(char=? 1 #\a))

(test #t char<? #\A)
(test #t char<? #\A #\B)
(test #t char<? #\A #\B #\C)
(test #f char<? #\A #\B #\A)
(test #f char<? #\A #\A #\C)
(test #t char<? #\a #\b)
(test #f char<? #\9 #\0)
(test #f char<? #\A #\A)
(test #f char<? #\370 #\370)
(test #f char<? #\371 #\370)
(test #t char<? #\370 #\371)
(arity-test char<? 1 -1)
(error-test '(char<? #\a 1)) 
(error-test '(char<? #\a #\a 1)) 
(error-test '(char<? 1 #\a))

(test #t char>? #\A)
(test #f char>? #\A #\B)
(test #t char>? #\B #\A)
(test #f char>? #\A #\B #\C)
(test #f char>? #\B #\A #\C)
(test #t char>? #\C #\B #\A)
(test #f char>? #\a #\b)
(test #t char>? #\9 #\0)
(test #f char>? #\A #\A)
(test #f char>? #\370 #\370)
(test #t char>? #\371 #\370)
(test #f char>? #\370 #\371)
(arity-test char>? 1 -1)
(error-test '(char>? #\a 1)) 
(error-test '(char>? #\a #\a 1)) 
(error-test '(char>? 1 #\a))

(test #t char<=? #\A)
(test #t char<=? #\A #\B)
(test #t char<=? #\A #\B #\C)
(test #t char<=? #\A #\A #\C)
(test #f char<=? #\A #\B #\A)
(test #f char<=? #\B #\A #\C)
(test #t char<=? #\a #\b)
(test #f char<=? #\9 #\0)
(test #t char<=? #\A #\A)
(test #t char<=? #\370 #\370)
(test #f char<=? #\371 #\370)
(test #t char<=? #\370 #\371)
(arity-test char<=? 1 -1)
(error-test '(char<=? #\a 1)) 
(error-test '(char<=? #\b #\a 1)) 
(error-test '(char<=? 1 #\a))

(test #t char>=? #\A)
(test #f char>=? #\A #\B)
(test #f char>=? #\a #\b)
(test #t char>=? #\9 #\0)
(test #t char>=? #\A #\A)
(test #t char>=? #\370 #\370)
(test #t char>=? #\371 #\370)
(test #f char>=? #\370 #\371)
(arity-test char>=? 1 -1)
(error-test '(char>=? #\a 1)) 
(error-test '(char>=? #\a #\b 1)) 
(error-test '(char>=? 1 #\a))

(test #t char-ci=? #\A)
(test #f char-ci=? #\A #\B)
(test #f char-ci=? #\A #\A #\B)
(test #f char-ci=? #\a #\B)
(test #f char-ci=? #\A #\b)
(test #f char-ci=? #\a #\b)
(test #f char-ci=? #\9 #\0)
(test #t char-ci=? #\A #\A)
(test #t char-ci=? #\A #\a)
(test #t char-ci=? #\A #\a #\A)
(test #t char-ci=? #\370 #\370)
(test #f char-ci=? #\371 #\370)
(test #f char-ci=? #\370 #\371)
(arity-test char-ci=? 1 -1)
(error-test '(char-ci=? #\a 1)) 
(error-test '(char-ci=? #\a #\b 1)) 
(error-test '(char-ci=? 1 #\a))

(test #t char-ci<? #\A)
(test #t char-ci<? #\A #\B)
(test #t char-ci<? #\A #\B #\C)
(test #t char-ci<? #\a #\B)
(test #t char-ci<? #\A #\b)
(test #t char-ci<? #\A #\b #\C)
(test #t char-ci<? #\a #\b)
(test #f char-ci<? #\9 #\0)
(test #f char-ci<? #\A #\A)
(test #f char-ci<? #\A #\a)
(test #f char-ci<? #\A #\b #\B)
(test #f char-ci<? #\370 #\370)
(test #f char-ci<? #\371 #\370)
(test #t char-ci<? #\370 #\371)
(arity-test char-ci<? 1 -1)
(error-test '(char-ci<? #\a 1)) 
(error-test '(char-ci<? #\b #\a 1)) 
(error-test '(char-ci<? 1 #\a))

(test #t char-ci>? #\A)
(test #f char-ci>? #\A #\B)
(test #f char-ci>? #\B #\A #\C)
(test #t char-ci>? #\C #\B #\A)
(test #f char-ci>? #\a #\B)
(test #f char-ci>? #\A #\b)
(test #f char-ci>? #\a #\b)
(test #t char-ci>? #\C #\b #\A)
(test #t char-ci>? #\9 #\0)
(test #f char-ci>? #\A #\A)
(test #f char-ci>? #\A #\a)
(test #f char-ci>? #\370 #\370)
(test #t char-ci>? #\371 #\370)
(test #f char-ci>? #\370 #\371)
(arity-test char-ci>? 1 -1)
(error-test '(char-ci>? #\a 1)) 
(error-test '(char-ci>? #\a #\b 1)) 
(error-test '(char-ci>? 1 #\a))

(test #t char-ci<=? #\A)
(test #t char-ci<=? #\A #\B)
(test #t char-ci<=? #\a #\B)
(test #t char-ci<=? #\a #\B #\C)
(test #f char-ci<=? #\a #\b #\A)
(test #t char-ci<=? #\A #\b)
(test #t char-ci<=? #\a #\b)
(test #f char-ci<=? #\9 #\0)
(test #t char-ci<=? #\A #\A)
(test #t char-ci<=? #\A #\a)
(test #t char-ci<=? #\370 #\370)
(test #f char-ci<=? #\371 #\370)
(test #t char-ci<=? #\370 #\371)
(arity-test char-ci<=? 1 -1)
(error-test '(char-ci<=? #\a 1)) 
(error-test '(char-ci<=? #\b #\a 1)) 
(error-test '(char-ci<=? 1 #\a))

(test #t char-ci>=? #\A)
(test #f char-ci>=? #\A #\B)
(test #f char-ci>=? #\B #\A #\C)
(test #t char-ci>=? #\B #\B #\A)
(test #f char-ci>=? #\a #\B)
(test #f char-ci>=? #\A #\b)
(test #f char-ci>=? #\a #\b)
(test #t char-ci>=? #\9 #\0)
(test #t char-ci>=? #\A #\A)
(test #t char-ci>=? #\A #\a)
(test #t char-ci>=? #\370 #\370)
(test #t char-ci>=? #\371 #\370)
(test #f char-ci>=? #\370 #\371)
(arity-test char-ci>=? 1 -1)
(error-test '(char-ci>=? #\a 1)) 
(error-test '(char-ci>=? #\a #\b 1)) 
(error-test '(char-ci>=? 1 #\a))

(define (ascii-range start end)
  (let ([s (or (and (number? start) start) (char->integer start))]
	[e (or (and (number? end) end) (char->integer end))])
    (let loop ([n e][l (list (integer->char e))])
      (if (= n s)
	  l
	  (let ([n (sub1 n)])
	    (loop n (cons (integer->char n) l)))))))

(define basic-uppers (ascii-range #\A #\Z))
(define uppers basic-uppers)
(define basic-lowers (ascii-range #\a #\z))
(define lowers basic-lowers)
(when (eq? (system-type) 'macos)
  ; There are more alphabetics:
  (set! uppers (append uppers
  					   (ascii-range 128 134)
  					   (ascii-range 174 175)
  					   (ascii-range 203 206)
  					   (ascii-range 217 217)
  					   (ascii-range 229 239)
  					   (ascii-range 241 244)))
  (set! lowers (append lowers
  					   (ascii-range 135 159)
  					   (ascii-range 190 191)
  					   (ascii-range 207 207)
  					   (ascii-range 216 216))))
(define alphas (append uppers lowers))
(define digits (ascii-range #\0 #\9))
(define whites (list #\newline #\return #\space #\page #\tab #\vtab))

(define (test-all is-a? name members)
  (let loop ([n 0])
    (unless (= n 256)
      (let ([c (integer->char n)])
	(test (and (memq c members) #t) `(,is-a? (integer->char ,n)) (is-a? c))
	(loop (add1 n)))))
  (arity-test char-alphabetic? 1 1)
  (error-test `(,name 1)))

(test-all char-alphabetic? 'char-alphabetic? alphas) 
(test-all char-numeric? 'char-numeric? digits) 
(test-all char-whitespace? 'char-whitespace? whites) 
(test-all char-upper-case? 'char-upper-case? uppers) 
(test-all char-lower-case? 'char-lower-case? lowers) 

(let loop ([n 0])
  (unless (= n 256)
     (test n 'integer->char (char->integer (integer->char n)))
     (loop (add1 n))))

(test 0 char->integer #\nul)
(test 10 char->integer #\newline)
(test 13 char->integer #\return)
(test 9 char->integer #\tab)
(test 8 char->integer #\backspace)
(test 12 char->integer #\page)
(test 32 char->integer #\space)
(test 127 char->integer #\rubout)
(test #\null 'null #\nul)
(test #\newline 'linefeed #\linefeed)

(test #\. integer->char (char->integer #\.))
(test #\A integer->char (char->integer #\A))
(test #\a integer->char (char->integer #\a))
(test #\371 integer->char (char->integer #\371))
(arity-test integer->char 1 1)
(arity-test char->integer 1 1)
(error-test '(integer->char 5.0))
(error-test '(integer->char 'a))
(error-test '(integer->char -1))
(error-test '(integer->char 256))
(error-test '(integer->char 10000000000000000))
(error-test '(char->integer 5))

(define (test-up/down case case-name members amembers memassoc)
  (let loop ([n 0])
    (unless (= n 256)
      (let ([c (integer->char n)])
	(if (memq c members)
	    (if (memq c amembers)
	      (test (cdr (assq c memassoc)) case c)
	      (test (case c) case c)) ; BOGUS! Could tweak Mac testing here
	    (test n `(char->integer (,case-name (integer->char ,n))) (char->integer (case c)))))
      (loop (add1 n))))
  (arity-test case 1 1)
  (error-test `(,case-name 2)))

(test-up/down char-upcase 'char-upcase lowers basic-lowers (map cons basic-lowers basic-uppers))
(test-up/down char-downcase 'char-downcase uppers basic-uppers (map cons basic-uppers basic-lowers))

((load-relative "censor.ss")
 (lambda ()
   (let loop ([n 0])
     (unless (= n 256)
       (let ([c (integer->char n)])
	 (if (or (char<=? #\a c #\z)
		 (char<=? #\A c #\Z)
		 (char<=? #\0 c #\9))
	     (begin
	       (test c latin-1-integer->char n)
	       (test n char->latin-1-integer c))
	     (when (latin-1-integer->char n)
	       (test n char->latin-1-integer (latin-1-integer->char n)))))
       (loop (add1 n))))))

(arity-test latin-1-integer->char 1 1)
(arity-test char->latin-1-integer 1 1)
(error-test '(latin-1-integer->char 5.0))
(error-test '(latin-1-integer->char 'a))
(error-test '(latin-1-integer->char -1))
(error-test '(latin-1-integer->char 256))
(error-test '(latin-1-integer->char 10000000000000000))
(error-test '(char->latin-1-integer 5))

(SECTION 6 7)
(test #t string? "The word \"recursion\\\" has many meanings.")
(test #t string? "")
(arity-test string? 1 1)
(test 3 'make-string (string-length (make-string 3)))
(test "" make-string 0)
(arity-test make-string 1 2)
(error-test '(make-string "hello"))
(error-test '(make-string 5 "hello"))
(error-test '(make-string 5.0 #\b))
(error-test '(make-string 5.2 #\a))
(error-test '(make-string -5 #\f))
(error-test '(make-string 500000000000000 #\f) exn:misc:out-of-memory?)

(define f (make-string 3 #\*))
(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
(arity-test string-set! 3 3)
(error-test '(string-set! "hello" 0 #\a)) ; immutable string constant
(define hello-string (string-copy "hello"))
(error-test '(string-set! hello-string 'a #\a))
(error-test '(string-set! 'hello 4 #\a))
(error-test '(string-set! hello-string 4 'a))
(error-test '(string-set! hello-string 4.0 'a))
(error-test '(string-set! hello-string 5 #\a) exn:application:mismatch?)
(error-test '(string-set! hello-string -1 #\a))
(error-test '(string-set! hello-string (expt 2 100) #\a) exn:application:mismatch?)
(test "abc" string #\a #\b #\c)
(test "" string)
(error-test '(string #\a 1))
(error-test '(string 1 #\a))
(error-test '(string 1))
(test 3 string-length "abc")
(test 0 string-length "")
(arity-test string-length 1 1)
(error-test '(string-length 'apple))
(test #\a string-ref "abc" 0)
(test #\c string-ref "abc" 2)
(arity-test string-ref 2 2)
(error-test '(string-ref 'apple 4))
(error-test '(string-ref "apple" 4.0))
(error-test '(string-ref "apple" '(4)))
(error-test '(string-ref "apple" 5) exn:application:mismatch?)
(error-test '(string-ref "" 0) exn:application:mismatch?)
(error-test '(string-ref "" (expt 2 100)) exn:application:mismatch?)
(error-test '(string-ref "apple" -1))
(test "" substring "ab" 0 0)
(test "" substring "ab" 1 1)
(test "" substring "ab" 2 2)
(test "a" substring "ab" 0 1)
(test "b" substring "ab" 1 2)
(test "ab" substring "ab" 0 2)
(test (string #\a #\nul #\b) substring (string #\- #\a #\nul #\b #\*) 1 4)
(arity-test substring 3 3)
(error-test '(substring 'hello 2 3))
(error-test '(substring "hello" "2" 3))
(error-test '(substring "hello" 2.0 3))
(error-test '(substring "hello" 2 3.0))
(error-test '(substring "hello" 2 "3"))
(error-test '(substring "hello" 2 7) exn:application:mismatch?)
(error-test '(substring "hello" -2 3))
(error-test '(substring "hello" 4 3) exn:application:mismatch?)
(error-test '(substring "hello" (expt 2 100) 3) exn:application:mismatch?)
(error-test '(substring "hello" (expt 2 100) 5) exn:application:mismatch?)
(error-test '(substring "hello" 3 (expt 2 100)) exn:application:mismatch?)
(test "foobar" string-append "foo" "bar")
(test "foo" string-append "foo")
(test "foo" string-append "foo" "")
(test "foogoo" string-append "foo" "" "goo")
(test "foo" string-append "" "foo")
(test "" string-append)
(test (string #\a #\nul #\b #\c #\nul #\d) 
      string-append (string #\a #\nul #\b) (string #\c #\nul #\d))
(error-test '(string-append 1))
(error-test '(string-append "hello" 1))
(error-test '(string-append "hello" 1 "done"))
(test "" make-string 0)
(define s (string-copy "hello"))
(define s2 (string-copy s))
(test "hello" 'string-copy s2)
(string-set! s 2 #\x)
(test "hello" 'string-copy s2)
(test (string #\a #\nul #\b) string-copy (string #\a #\nul #\b))
(string-fill! s #\x)
(test "xxxxx" 'string-fill! s)
(arity-test string-copy 1 1)
(arity-test string-fill! 2 2)
(error-test '(string-copy 'blah))
(error-test '(string-fill! "oops" 5))

(define ax (string #\a #\nul #\370 #\x))
(define abigx (string #\a #\nul #\370 #\X))
(define ax2 (string #\a #\nul #\370 #\x))
(define ay (string #\a #\nul #\371 #\x))

(test #t string=? "string")
(test #t string<? "string")
(test #t string>? "string")
(test #t string<=? "string")
(test #t string>=? "string")
(test #t string-ci=? "string")
(test #t string-ci<? "string")
(test #t string-ci>? "string")
(test #t string-ci<=? "string")
(test #t string-ci>=? "string")

(test #t string=? "" "")
(test #f string<? "" "")
(test #f string>? "" "")
(test #t string<=? "" "")
(test #t string>=? "" "")
(test #t string-ci=? "" "")
(test #f string-ci<? "" "")
(test #f string-ci>? "" "")
(test #t string-ci<=? "" "")
(test #t string-ci>=? "" "")

(test #f string=? "A" "B")
(test #f string=? "a" "b")
(test #f string=? "9" "0")
(test #t string=? "A" "A")
(test #f string=? "A" "AB")
(test #t string=? ax ax2)
(test #f string=? ax abigx)
(test #f string=? ax ay)
(test #f string=? ay ax)

(test #t string<? "A" "B")
(test #t string<? "a" "b")
(test #f string<? "9" "0")
(test #f string<? "A" "A")
(test #t string<? "A" "AB")
(test #f string<? "AB" "A")
(test #f string<? ax ax2)
(test #t string<? ax ay)
(test #f string<? ay ax)

(test #f string>? "A" "B")
(test #f string>? "a" "b")
(test #t string>? "9" "0")
(test #f string>? "A" "A")
(test #f string>? "A" "AB")
(test #t string>? "AB" "A")
(test #f string>? ax ax2)
(test #f string>? ax ay)
(test #t string>? ay ax)

(test #t string<=? "A" "B")
(test #t string<=? "a" "b")
(test #f string<=? "9" "0")
(test #t string<=? "A" "A")
(test #t string<=? "A" "AB")
(test #f string<=? "AB" "A")
(test #t string<=? ax ax2)
(test #t string<=? ax ay)
(test #f string<=? ay ax)

(test #f string>=? "A" "B")
(test #f string>=? "a" "b")
(test #t string>=? "9" "0")
(test #t string>=? "A" "A")
(test #f string>=? "A" "AB")
(test #t string>=? "AB" "A")
(test #t string>=? ax ax2)
(test #f string>=? ax ay)
(test #t string>=? ay ax)

(test #f string-ci=? "A" "B")
(test #f string-ci=? "a" "B")
(test #f string-ci=? "A" "b")
(test #f string-ci=? "a" "b")
(test #f string-ci=? "9" "0")
(test #t string-ci=? "A" "A")
(test #t string-ci=? "A" "a")
(test #f string-ci=? "A" "AB")
(test #t string-ci=? ax ax2)
(test #t string-ci=? ax abigx)
(test #f string-ci=? ax ay)
(test #f string-ci=? ay ax)
(test #f string-ci=? abigx ay)
(test #f string-ci=? ay abigx)

(test #t string-ci<? "A" "B")
(test #t string-ci<? "a" "B")
(test #t string-ci<? "A" "b")
(test #t string-ci<? "a" "b")
(test #f string-ci<? "9" "0")
(test #f string-ci<? "A" "A")
(test #f string-ci<? "A" "a")
(test #t string-ci<? "A" "AB")
(test #f string-ci<? "AB" "A")
(test #f string-ci<? ax ax2)
(test #f string-ci<? ax abigx)
(test #t string-ci<? ax ay)
(test #f string-ci<? ay ax)
(test #t string-ci<? abigx ay)
(test #f string-ci<? ay abigx)

(test #f string-ci>? "A" "B")
(test #f string-ci>? "a" "B")
(test #f string-ci>? "A" "b")
(test #f string-ci>? "a" "b")
(test #t string-ci>? "9" "0")
(test #f string-ci>? "A" "A")
(test #f string-ci>? "A" "a")
(test #f string-ci>? "A" "AB")
(test #t string-ci>? "AB" "A")
(test #f string-ci>? ax ax2)
(test #f string-ci>? ax abigx)
(test #f string-ci>? ax ay)
(test #t string-ci>? ay ax)
(test #f string-ci>? abigx ay)
(test #t string-ci>? ay abigx)

(test #t string-ci<=? "A" "B")
(test #t string-ci<=? "a" "B")
(test #t string-ci<=? "A" "b")
(test #t string-ci<=? "a" "b")
(test #f string-ci<=? "9" "0")
(test #t string-ci<=? "A" "A")
(test #t string-ci<=? "A" "a")
(test #t string-ci<=? "A" "AB")
(test #f string-ci<=? "AB" "A")
(test #t string-ci<=? ax ax2)
(test #t string-ci<=? ax abigx)
(test #t string-ci<=? ax ay)
(test #f string-ci<=? ay ax)
(test #t string-ci<=? abigx ay)
(test #f string-ci<=? ay abigx)

(test #f string-ci>=? "A" "B")
(test #f string-ci>=? "a" "B")
(test #f string-ci>=? "A" "b")
(test #f string-ci>=? "a" "b")
(test #t string-ci>=? "9" "0")
(test #t string-ci>=? "A" "A")
(test #t string-ci>=? "A" "a")
(test #f string-ci>=? "A" "AB")
(test #t string-ci>=? "AB" "A")
(test #t string-ci>=? ax ax2)
(test #t string-ci>=? ax abigx)
(test #f string-ci>=? ax ay)
(test #t string-ci>=? ay ax)
(test #f string-ci>=? abigx ay)
(test #t string-ci>=? ay abigx)

(map (lambda (pred)
       (arity-test pred 1 -1)
       (let ([predname (string->symbol
			(primitive-name pred))])
	 (error-test `(,predname "a" 1))
	 (error-test `(,predname "a" "b" 5))
	 (error-test `(,predname 1 "a"))))
     (list string=? 
	   string>? 
	   string<? 
	   string>=? 
	   string<=? 
	   string-ci=? 
	   string-ci>? 
	   string-ci<? 
	   string-ci>=? 
	   string-ci<=?))

(define r (regexp "(-[0-9]*)+"))
(test '("-12--345" "-345") regexp-match r "a-12--345b")
(test '((1 . 9) (5 . 9)) regexp-match-positions r "a-12--345b")
(test '("--345" "-345") regexp-match r "a-12--345b" 2)
(test '("--34" "-34") regexp-match r "a-12--345b" 2 8)
(test '((4 . 9) (5 . 9)) regexp-match-positions r "a-12--345b" 2)
(test '((4 . 8) (5 . 8)) regexp-match-positions r "a-12--345b" 2 8)
(test '("a-b") regexp-match "a[-c]b" "a-b")
(test '("a-b") regexp-match "a[c-]b" "a-b")
(test #f regexp-match "x+" "12345")
(test "su casa" regexp-replace "mi" "mi casa" "su")
(define r2 (regexp "([Mm])i ([a-zA-Z]*)"))
(define insert "\\1y \\2")
(test "My Casa" regexp-replace r2 "Mi Casa" insert)
(test "my cerveza Mi Mi Mi" regexp-replace r2 "mi cerveza Mi Mi Mi" insert)
(test "my cerveza My Mi Mi" regexp-replace* r2 "mi cerveza Mi Mi Mi" insert)
(test "bbb" regexp-replace* "a" "aaa" "b")

;; Test regexp with null chars:
(let* ([s (string #\a #\b #\nul #\c)]
       [3s (string-append s s s)])
  (test #f regexp-match (string #\nul) "no nulls")
  (test (list s) regexp-match s s)
  (test (list 3s s) regexp-match (format "(~a)*" s) 3s)
  (test (list (string #\b #\nul #\c)) regexp-match (string #\[ #\nul #\b #\] #\* #\c) s)
  (test (list (string #\a #\b #\nul)) regexp-match (string #\a #\[ #\b #\nul #\] #\+) s)
  (test "hihihi" regexp-replace* (string #\nul) (string #\nul #\nul #\nul) "hi"))
(test (string #\- #\nul #\+ #\- #\nul #\+ #\- #\nul #\+)
      regexp-replace* "a" "aaa" (string #\- #\nul #\+))

;; Check extremely many subexpressions:
(for-each
 (lambda (mx)
   (let* ([v (make-vector mx null)]
	  [open (make-vector mx #t)])
     (let loop ([n 0][m 0][s null])
       (cond
	[(and (= n mx) (zero? m))
	 (let* ([s (list->string (reverse! s))]
		[plain (regexp-replace* "[()]" s "")])
	   (test (cons plain (map list->string (map reverse! (vector->list v)))) regexp-match s plain))]
	[(or (= n mx) (< (random 10) 3))
	 (if (and (positive? m)
		  (< (random 10) 7))
	     (begin
	       (let loop ([p 0][m (sub1 m)])
		 (if (vector-ref open p)
		     (if (zero? m)
			 (vector-set! open p #f)
			 (loop (add1 p) (sub1 m)))
		     (loop (add1 p) m)))
	       (loop n (sub1 m) (cons #\) s)))

	     (let ([c (integer->char (+ (char->integer #\a) (random 26)))])
	       (let loop ([p 0])
		 (unless (= p n)
		   (when (vector-ref open p)
		     (vector-set! v p (cons c (vector-ref v p))))
		   (loop (add1 p))))
	       (loop n m (cons c s))))]
	[else
	 (loop (add1 n) (add1 m) (cons #\( s))]))))
 '(1 10 100 500))


(define (test-bad-re-args who)
  (error-test `(,who 'e "hello"))
  (error-test `(,who "e" 'hello))
  (error-test `(,who "e" "hello" -1 5))
  (error-test `(,who "e" "hello" 1 +inf.0))
  (error-test `(,who "e" "" 0 1) exn:application:mismatch?)
  (error-test `(,who "e" "hello" 3 2) exn:application:mismatch?)
  (error-test `(,who "e" "hello" 3 12) exn:application:mismatch?)
  (error-test `(,who "e" "hello" (expt 2 100) 5)  exn:application:mismatch?))
(test-bad-re-args 'regexp-match)
(test-bad-re-args 'regexp-match-positions)

(arity-test regexp 1 1)
(arity-test regexp? 1 1)
(arity-test regexp-match 2 4)
(arity-test regexp-match-positions 2 4)
(arity-test regexp-replace 3 3)
(arity-test regexp-replace* 3 3)

(SECTION 6 8)
(test #t vector? '#(0 (2 2 2 2) "Anna"))
(test #t vector? '#())
(arity-test vector? 1 1)
(test '#(a b c) vector 'a 'b 'c)
(test '#() vector)
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
(test 0 vector-length '#())
(arity-test vector-length 1 1)
(error-test '(vector-length "apple"))
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
(arity-test vector-ref 2 2)
(error-test '(vector-ref "apple" 3))
(error-test '(vector-ref #(4 5 6) 3) exn:application:mismatch?)
(error-test '(vector-ref #() 0) exn:application:mismatch?)
(error-test '(vector-ref #() (expt 2 100)) exn:application:mismatch?)
(error-test '(vector-ref #(4 5 6) -1))
(error-test '(vector-ref #(4 5 6) 2.0))
(error-test '(vector-ref #(4 5 6) "2"))
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
	(let ((vec (vector 0 '(2 2 2 2) "Anna")))
	  (vector-set! vec 1 '("Sue" "Sue"))
	  vec))
(test '#(hi hi) make-vector 2 'hi)
(test '#() make-vector 0)
(test '#() make-vector 0 'a)
(arity-test make-vector 1 2)
(error-test '(make-vector "a" 'a))
(error-test '(make-vector 1.0 'a))
(error-test '(make-vector 10.2 'a))
(error-test '(make-vector -1 'a))
(error-test '(make-vector 1000000000000000000000 'a) exn:misc:out-of-memory?)
(arity-test vector-set! 3 3)
(error-test '(vector-set! #() 0 'x) exn:application:mismatch?)
(error-test '(vector-set! #(1 2 3) -1 'x))
(error-test '(vector-set! #(1 2 3) 3 'x) exn:application:mismatch?)
(error-test '(vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?)
(error-test '(vector-set! '(1 2 3) 2 'x))
(error-test '(vector-set! #(1 2 3) "2" 'x))
(define v (quote #(1 2 3)))
(vector-fill! v 0)
(test (quote #(0 0 0)) 'vector-fill! v)
(arity-test vector-fill! 2 2)
(error-test '(vector-fill! '(1 2 3) 0))

(SECTION 6 9)
(test #t procedure? car)
(test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x)))
(test #f procedure? '(lambda (x) (* x x)))
(test #t call-with-current-continuation procedure?)
(test #t call-with-escape-continuation procedure?)
(test #t procedure? (case-lambda ((x) x) ((x y) (+ x y))))
(arity-test procedure? 1 1)

(test 7 apply + (list 3 4))
(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
(test 17 apply + 10 (list 3 4))
(test '() apply list '())
(define compose (lambda (f g) (lambda args (f (apply g args)))))
(test 30 (compose sqrt *) 12 75)
(error-test '(apply) exn:application:arity?)
(error-test '(apply (lambda x x)) exn:application:arity?)
(error-test '(apply (lambda x x) 1))
(error-test '(apply (lambda x x) 1 2))
(error-test '(apply (lambda x x) 1 '(2 . 3)))

(test '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6))
(test '#(0 1 4 9 16) 'for-each
	(let ((v (make-vector 5)))
		(for-each (lambda (i) (vector-set! v i (* i i)))
			'(0 1 2 3 4))
		v))

(define (map-tests map)
  (let ([size? exn:application:mismatch?]
	[non-list? type?])
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '1))
    (error-test `(,map (lambda (x y) (+ x y)) '2 '(1 2)))
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 3)) size?)
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2)) size?)
    (error-test `(,map (lambda (x) (+ x)) '(1 2 . 3)) non-list?)
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2)) non-list?)
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2 3)) non-list?)
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 . 3)) non-list?)
    (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2 . 3)) non-list?)
    (error-test `(,map) exn:application:arity?)
    (error-test `(,map (lambda (x y) (+ x y))) exn:application:arity?)
    (error-test `(,map (lambda () 10) null) exn:application:mismatch?)
    (error-test `(,map (case-lambda [() 9] [(x y) 10]) '(1 2 3)) exn:application:mismatch?)
    (error-test `(,map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?)))
(map-tests 'map)
(map-tests 'for-each)
(map-tests 'andmap)
(map-tests 'ormap)

(test (void) for-each (lambda (x) (values 1 2)) '(1 2))
(error-test '(map (lambda (x) (values 1 2)) '(1 2)) arity?)

(test #t andmap add1 null)
(test #f ormap add1 null)
(test #f andmap positive? '(1 -2 3))
(test #t ormap positive? '(1 -2 3))
(test #f andmap negative? '(1 -2 3))
(test #t ormap negative? '(1 -2 3))
(test 4 andmap add1 '(1 2 3))
(test 2 ormap add1 '(1 2 3))

(error-test '(ormap (lambda (x) (values 1 2)) '(1 2)) arity?)
(error-test '(andmap (lambda (x) (values 1 2)) '(1 2)) arity?)

(error-test '(ormap (lambda (x) (values 1 2)) '(1)) arity?)
(error-test '(andmap (lambda (x) (values 1 2)) '(1)) arity?)

(test -3 call-with-current-continuation
		(lambda (exit)
		 (for-each (lambda (x) (if (negative? x) (exit x)))
		 	'(54 0 37 -3 245 19))
		#t))
(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))))))
(test 4 list-length '(1 2 3 4))
(test #f list-length '(a b . c))
(test '() map cadr '())

;;; This tests full conformance of call-with-current-continuation.  It
;;; is a separate test because some schemes do not support call/cc
;;; other than escape procedures.  I am indebted to
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
;;; trees constructed of conses.  
(define (next-leaf-generator obj eot)
  (letrec ((return #f)
	   (cont (lambda (x)
		   (recurx obj)
		   (set! cont (lambda (x) (return eot)))
		   (cont #f)))
	   (recurx (lambda (obj)
		      (if (pair? obj)
			  (for-each recurx 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)))))
(define (test-cont)
  (newline)
  (display ";testing continuations; ")
  (SECTION 6 9)
  (test #t leaf-eq? '(a (b (c))) '((a) b c))
  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
  '(report-errs))

(define (test-cc-values test-call/cc)
  (test '(a b c)
	call-with-values
	(lambda ()
	  (test-call/cc
	   (lambda (k)
	     (dynamic-wind
	      void
	      (lambda ()
		(k 'a 'b 'c))
	      (lambda ()
		(values 1 2))))))
	list)

  (test 1 dynamic-wind
	(lambda () (test-call/cc void))
	(lambda () 1)
	(lambda () (test-call/cc void)))

  ; Try devious jumping with pre- and post-thunks:
  (test 2 test-call/cc
	(lambda (exit)
	  (dynamic-wind
	   (lambda () (exit 2))
	   void
	   void)))
  (test 3 test-call/cc
	(lambda (exit)
	  (dynamic-wind
	   void
	   void
	   (lambda () (exit 3)))))

  (let ([rv
	 (lambda (get-v)
	   (let ([x 0])
	     (test-call/cc
	      (lambda (exit)
		(dynamic-wind
		 void
		 (lambda () (exit))
		 (lambda () (set! x (get-v))))))
	     x))]
	[r56
	 (lambda ()
	   (let ([x 0]
		 [y 1]
		 [c1 #f])
	     (dynamic-wind
	      (lambda () (set! x (add1 x)))
	      (lambda () 
		(let/cc k (set! c1 k))
		(if (>= x 5)
		    (set! c1 #f)))
	      (lambda () (set! y (add1 y))))
	     (when c1 (c1))
	     (list x y)))]
	[rx.y
	 (lambda (get-x get-y)
	   (let ([c1 #f]
		 [x 0]
		 [y 0])
	     (let ([v
		    (dynamic-wind
		     (lambda () (set! y x))
		     (lambda () (let/cc k (set! c1 k)))
		     (lambda () 
		       (set! x (get-x))
		       (when c1
			     ((begin0
			       c1
			       (set! c1 #f))
			      (get-y)))))])
	       (cons y v))))]
	[rv2
	 (lambda (get-v)
	   (let ([c1 #f]
		 [give-up #f])
	     (test-call/cc
	      (lambda (exit)
		(dynamic-wind
		 (lambda () (when give-up (give-up (get-v))))
		 (lambda () (let/cc k (set! c1 k)))
		 (lambda () (set! give-up exit) (c1)))))))]
	[r10-11-12
	 (lambda ()
	   (let ([c2 #f]
		 [x 10]
		 [y 11])
	     (let ([v (dynamic-wind
		       (lambda () (set! y (add1 y)))
		       (lambda () (begin0 x (set! x (add1 x))))
		       (lambda () (let/cc k (set! c2 k))))])
	       (when c2 ((begin0
			  c2
			  (set! c2 #f))))
	       (list v x y))))]
	[r13.14
	 (lambda ()
	   (let ([c0 #f]
		 [x 11]
		 [y 12])
	     (dynamic-wind
	      (lambda () (let/cc k (set! c0 k)))
	      (lambda () (set! x (add1 x)))
	      (lambda () (set! y (add1 y))
		      (when c0 ((begin0
				 c0
				 (set! c0 #f))))))
	     (cons x y)))]
	[ra-b-a-b
	 (lambda (get-a get-b)
	   (let ([l null])
	     (let ((k-in (test-call/cc (lambda (k1)
					 (dynamic-wind
					  (lambda () (set! l (append l (list (get-a)))))
					  (lambda ()
					    (call/cc (lambda (k2) (k1 k2))))
					  (lambda ()  (set! l (append l (list (get-b))))))))))
	       (k-in (lambda (v) l)))))])

  (test 4 rv (lambda () 4))
  (test '(5 6) r56)

  (test '(7 . 8) rx.y (lambda () 7) (lambda () 8))

  (test 9 rv2 (lambda () 9))

  (test '(10 11 12) r10-11-12)

  (test '(13 . 14) r13.14)

  ; !!! fixed in 50:
  (test '(enter exit enter exit)
	ra-b-a-b (lambda () 'enter) (lambda () 'exit))

  (test '((13 . 14) (10 11 12) (13 . 14) (10 11 12))
	ra-b-a-b r13.14 r10-11-12)
  (test '((10 11 12) (13 . 14) (10 11 12) (13 . 14))
	ra-b-a-b r10-11-12 r13.14)

  (test '((enter exit enter exit)
	  (exit enter exit enter)
	  (enter exit enter exit)
	  (exit enter exit enter))
	ra-b-a-b 
	(lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))
	(lambda () (ra-b-a-b (lambda () 'exit) (lambda () 'enter))))

  (test '(enter exit enter exit)
	rv (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))))
  (test '(enter exit enter exit)
	rv2 (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))))

  (test '(10 11 12) rv r10-11-12)
  (test '(10 11 12) rv2 r10-11-12)

  (test '(13 . 14) rv r13.14)
  (test '(13 . 14) rv2 r13.14)

  (test 12 'dw/ec (test-call/cc
		   (lambda (k0)
		     (test-call/cc
		      (lambda (k1)
			(test-call/cc
			 (lambda (k2)
			   (dynamic-wind
			    void
			    (lambda () (k1 6))
			    (lambda () (k2 12))))))))))

  ;; !!! fixed in 53 (for call/ec)
  (test 13 'dw/ec (test-call/cc
		   (lambda (k0)
		     (test-call/cc
		      (lambda (k1)
			(test-call/cc
			 (lambda (k2)
			   (dynamic-wind
			    void
			    (lambda () (k1 6))
			    (lambda () (k2 12)))))
			(k0 13))))))

  ))
	      

(test-cc-values call/cc)
(test-cc-values call/ec)

(test 'ok
      'ec-cc-exn-combo
      (with-handlers ([void (lambda (x) 'ok)])
	(define f
	  (let ([k #f])
	    (lambda (n)
	      (case n
		[(0) (let/ec r (r (set! k (let/cc k k))))]
		[(1) (k)]))))
	(f 0)
	(f 1)))

(test '(1 2 3 4 1 2 3 4) 'dyn-wind-pre/post-order
      (let ([x null]
	    [go-back #f])
	(dynamic-wind
	 (lambda () (set! x (cons 4 x)))
	 (lambda () (dynamic-wind
		     (lambda () (set! x (cons 3 x)))
		     (lambda () (set! go-back (let/cc k k)))
		     (lambda () (set! x (cons 2 x)))))
	 (lambda () (set! x (cons 1 x))))
	(if (procedure? go-back)
	    (go-back 1)
	    x)))

(test '(5 . 5) 'suspended-cont-escape
      (let ([retry #f])
	(let ([v (let/ec exit
		   (dynamic-wind
		    void
		    (lambda () (exit 5))
		    (lambda ()
		      (let/ec inner-escape
			(set! retry (let/cc k k))
			(inner-escape 12)
			10))))])
	  (if (procedure? retry)
	      (retry 10)
	      (cons v v)))))

(test '(here) 'escape-interrupt-full-jump-up
      (let ([b #f]
	    [v null])
	(define (f g)
	  (dynamic-wind
	   void
	   g
	   (lambda () 
	     (set! v (cons 'here v))
	     (b 10))))
	
	(let/ec big
	  (set! b big)
	  (let/cc ok
	    (f (lambda ()
		 (ok #f)))))
	
	v))


(arity-test call/cc 1 1)
(arity-test call/ec 1 1)
(error-test '(call/cc 4))
(error-test '(call/cc (lambda () 0)))
(error-test '(call/ec 4))
(error-test '(call/ec (lambda () 0)))

(test #t primitive? car)
(test #f primitive? leaf-eq?)
(arity-test primitive? 1 1)

(test 1 arity arity)
(test 2 arity cons)
(test (make-arity-at-least 1) arity >)
(test (list 0 1) arity current-output-port)
(test (list 1 3 (make-arity-at-least 5))
      arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2]))
(arity-test arity 1 1)

(test #t procedure-arity-includes? cons 2)
(test #f procedure-arity-includes? cons 0)
(test #f procedure-arity-includes? cons 3)
(test #t procedure-arity-includes? list 3)
(test #t procedure-arity-includes? list 3000)
(test #t procedure-arity-includes? (lambda () 0) 0)
(test #f procedure-arity-includes? (lambda () 0) 1)
(test #f procedure-arity-includes? cons 10000000000000000000000000000)
(test #t procedure-arity-includes? list 10000000000000000000000000000)
(test #t procedure-arity-includes? (lambda x x) 10000000000000000000000000000)

(error-test '(procedure-arity-includes? cons -1))
(error-test '(procedure-arity-includes? cons 1.0))
(error-test '(procedure-arity-includes? 'cons 1))

(arity-test procedure-arity-includes? 2 2)

(newline)
(display ";testing scheme 4 functions; ")
(SECTION 6 7)
(test '(#\P #\space #\l) string->list "P l")
(test '() string->list "")
(test "1\\\"" list->string '(#\1 #\\ #\"))
(test "" list->string '())
(arity-test list->string 1 1)
(arity-test string->list 1 1)
(error-test '(string->list 'hello))
(error-test '(list->string 'hello))
(error-test '(list->string '(#\h . #\e)))
(SECTION 6 8)
(test '(dah dah didah) vector->list '#(dah dah didah))
(test '() vector->list '#())
(test '#(dididit dah) list->vector '(dididit dah))
(test '#() list->vector '())
(arity-test list->vector 1 1)
(arity-test vector->list 1 1)
(error-test '(vector->list 'hello))
(error-test '(list->vector 'hello))
(error-test '(list->vector '(#\h . #\e)))

(test-cont)

(report-errs)

"last item in file"
