Welcome to the CHICKEN Scheme pasting service

;;;
;;; make-tests.scm
;;;

(use srfi-1 vector-lib)

(define types/values
  '((fixnum . 1)
    (flonum . 1.0)
    (string . "foo")
    (character . #\a)
    (symbol . foo)
    (boolean . #t)
    (procedure . (lambda () 'foo))
    (empty-list . '())
    (pair . '(foo . bar))
    (list-of-fixnums . '(1 2 3))
    (list-of-flonums . '(1.0 2.0 3.0))
    (list-of-strings . '("a" "b" "c"))
    (list-of-characters . '(#\a #\b #\c))
    (list-of-lists . '((1 2) (3 4) (5 6)))
    (empty-vector . '#())
    (vector-of-fixnums . '#(1 2 3))
    (vector-of-flonums . '#(1.0 2.0 3.0))
    (vector-of-strings . '#("a" "b" "c"))
    (vector-of-characters . '#(#\a #\b #\c))
    (vector-of-lists . '#((1 2) (3 4) (5 6)))
    ))


(define any-object
  (map car types/values))

(define any-list
  '(list-of-fixnums list-of-flonums list-of-strings list-of-characters list-of-lists))

(define any-vector
  '(vector-of-fixnums vector-of-flonums vector-of-strings vector-of-characters vector-of-vectors))

(define number
  '(fixnum flonum))

(define (value-for type)
  (or (alist-ref type types/values)
      (error 'value-for "Unknown type: " type)))


(define (bad-types-for good-types)
  (remove (lambda (type)
            (memq type good-types))
          (map car types/values)))


(define (bad-values-for good-types)
  (map value-for (bad-types-for good-types)))


(define (make-tests-with-bad-argn prototype argn)
  (let* ((op (car prototype))
         (args-types (cdr prototype))
         (good-args (list->vector (map value-for (map car args-types)))))
    (let loop ((bad-values (bad-values-for (list-ref args-types argn))))
      (if (null? bad-values)
          '()
          (let* ((bv (car bad-values))
                 (bad-args (let ((ba (vector-copy good-args)))
                             (vector-set! ba argn bv)
                             ba)))
            (cons (cons op (vector->list bad-args))
                  (loop (cdr bad-values))))))))                


(define (make-tests-with-bad-args prototype)
  (let ((nargs (length (cdr prototype))))
    (if (zero? nargs)
        '()
        (let loop ((nargs (- nargs 1)))
          (if (= nargs -1)
              '()
              (append (make-tests-with-bad-argn prototype nargs)
                      (loop (- nargs 1))))))))
                

(define (write-tests tests)
  (for-each (lambda (test)
              (pp `(test-error ,test)))
            tests))


(define prototypes
  `((+ (fixnum flonum) (fixnum flonum))
    (add1 (fixnum flonum))
    (string-join (list-of-strings empty-list))
    (list-ref ,any-list (fixnum))
    (car ,(cons 'pair any-list))
    (cdr ,(cons 'pair any-list))
    ))


(pp '(use test srfi-13))
(pp '(test-begin "all"))
(for-each (lambda (prototype)
            (let ((op (symbol->string (car prototype))))
              (pp `(test-begin ,op))
              (write-tests (make-tests-with-bad-args prototype))
              (pp `(test-end ,op))))
          prototypes)
(pp '(test-end "all"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;; end of make-tests.scm ;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


$ csi -s make-tests.scm > tests.scm

$ cat tests.scm
(use test srfi-13)
(test-begin "all")
(test-begin "+")
(test-error (+ 1 "foo"))
(test-error (+ 1 #\a))
(test-error (+ 1 foo))
(test-error (+ 1 #t))
(test-error (+ 1 (lambda () 'foo)))
(test-error (+ 1 '()))
(test-error (+ 1 '(foo . bar)))
(test-error (+ 1 '(1 2 3)))
(test-error (+ 1 '(1.0 2.0 3.0)))
(test-error (+ 1 '("a" "b" "c")))
(test-error (+ 1 '(#\a #\b #\c)))
(test-error (+ 1 '((1 2) (3 4) (5 6))))
(test-error (+ 1 '#()))
(test-error (+ 1 '#(1 2 3)))
(test-error (+ 1 '#(1.0 2.0 3.0)))
(test-error (+ 1 '#("a" "b" "c")))
(test-error (+ 1 '#(#\a #\b #\c)))
(test-error (+ 1 '#((1 2) (3 4) (5 6))))
(test-error (+ "foo" 1))
(test-error (+ #\a 1))
(test-error (+ foo 1))
(test-error (+ #t 1))
(test-error (+ (lambda () 'foo) 1))
(test-error (+ '() 1))
(test-error (+ '(foo . bar) 1))
(test-error (+ '(1 2 3) 1))
(test-error (+ '(1.0 2.0 3.0) 1))
(test-error (+ '("a" "b" "c") 1))
(test-error (+ '(#\a #\b #\c) 1))
(test-error (+ '((1 2) (3 4) (5 6)) 1))
(test-error (+ '#() 1))
(test-error (+ '#(1 2 3) 1))
(test-error (+ '#(1.0 2.0 3.0) 1))
(test-error (+ '#("a" "b" "c") 1))
(test-error (+ '#(#\a #\b #\c) 1))
(test-error (+ '#((1 2) (3 4) (5 6)) 1))
(test-end "+")
(test-begin "add1")
(test-error (add1 "foo"))
(test-error (add1 #\a))
(test-error (add1 foo))
(test-error (add1 #t))
(test-error (add1 (lambda () 'foo)))
(test-error (add1 '()))
(test-error (add1 '(foo . bar)))
(test-error (add1 '(1 2 3)))
(test-error (add1 '(1.0 2.0 3.0)))
(test-error (add1 '("a" "b" "c")))
(test-error (add1 '(#\a #\b #\c)))
(test-error (add1 '((1 2) (3 4) (5 6))))
(test-error (add1 '#()))
(test-error (add1 '#(1 2 3)))
(test-error (add1 '#(1.0 2.0 3.0)))
(test-error (add1 '#("a" "b" "c")))
(test-error (add1 '#(#\a #\b #\c)))
(test-error (add1 '#((1 2) (3 4) (5 6))))
(test-end "add1")
(test-begin "string-join")
(test-error (string-join 1))
(test-error (string-join 1.0))
(test-error (string-join "foo"))
(test-error (string-join #\a))
(test-error (string-join foo))
(test-error (string-join #t))
(test-error (string-join (lambda () 'foo)))
(test-error (string-join '(foo . bar)))
(test-error (string-join '(1 2 3)))
(test-error (string-join '(1.0 2.0 3.0)))
(test-error (string-join '(#\a #\b #\c)))
(test-error (string-join '((1 2) (3 4) (5 6))))
(test-error (string-join '#()))
(test-error (string-join '#(1 2 3)))
(test-error (string-join '#(1.0 2.0 3.0)))
(test-error (string-join '#("a" "b" "c")))
(test-error (string-join '#(#\a #\b #\c)))
(test-error (string-join '#((1 2) (3 4) (5 6))))
(test-end "string-join")
(test-begin "list-ref")
(test-error (list-ref '(1 2 3) 1.0))
(test-error (list-ref '(1 2 3) "foo"))
(test-error (list-ref '(1 2 3) #\a))
(test-error (list-ref '(1 2 3) foo))
(test-error (list-ref '(1 2 3) #t))
(test-error (list-ref '(1 2 3) (lambda () 'foo)))
(test-error (list-ref '(1 2 3) '()))
(test-error (list-ref '(1 2 3) '(foo . bar)))
(test-error (list-ref '(1 2 3) '(1 2 3)))
(test-error (list-ref '(1 2 3) '(1.0 2.0 3.0)))
(test-error (list-ref '(1 2 3) '("a" "b" "c")))
(test-error (list-ref '(1 2 3) '(#\a #\b #\c)))
(test-error (list-ref '(1 2 3) '((1 2) (3 4) (5 6))))
(test-error (list-ref '(1 2 3) '#()))
(test-error (list-ref '(1 2 3) '#(1 2 3)))
(test-error (list-ref '(1 2 3) '#(1.0 2.0 3.0)))
(test-error (list-ref '(1 2 3) '#("a" "b" "c")))
(test-error (list-ref '(1 2 3) '#(#\a #\b #\c)))
(test-error (list-ref '(1 2 3) '#((1 2) (3 4) (5 6))))
(test-error (list-ref 1 1))
(test-error (list-ref 1.0 1))
(test-error (list-ref "foo" 1))
(test-error (list-ref #\a 1))
(test-error (list-ref foo 1))
(test-error (list-ref #t 1))
(test-error (list-ref (lambda () 'foo) 1))
(test-error (list-ref '() 1))
(test-error (list-ref '(foo . bar) 1))
(test-error (list-ref '#() 1))
(test-error (list-ref '#(1 2 3) 1))
(test-error (list-ref '#(1.0 2.0 3.0) 1))
(test-error (list-ref '#("a" "b" "c") 1))
(test-error (list-ref '#(#\a #\b #\c) 1))
(test-error (list-ref '#((1 2) (3 4) (5 6)) 1))
(test-end "list-ref")
(test-begin "car")
(test-error (car 1))
(test-error (car 1.0))
(test-error (car "foo"))
(test-error (car #\a))
(test-error (car foo))
(test-error (car #t))
(test-error (car (lambda () 'foo)))
(test-error (car '()))
(test-error (car '#()))
(test-error (car '#(1 2 3)))
(test-error (car '#(1.0 2.0 3.0)))
(test-error (car '#("a" "b" "c")))
(test-error (car '#(#\a #\b #\c)))
(test-error (car '#((1 2) (3 4) (5 6))))
(test-end "car")
(test-begin "cdr")
(test-error (cdr 1))
(test-error (cdr 1.0))
(test-error (cdr "foo"))
(test-error (cdr #\a))
(test-error (cdr foo))
(test-error (cdr #t))
(test-error (cdr (lambda () 'foo)))
(test-error (cdr '()))
(test-error (cdr '#()))
(test-error (cdr '#(1 2 3)))
(test-error (cdr '#(1.0 2.0 3.0)))
(test-error (cdr '#("a" "b" "c")))
(test-error (cdr '#(#\a #\b #\c)))
(test-error (cdr '#((1 2) (3 4) (5 6))))
(test-end "cdr")
(test-end "all")

$ csi -s tests.scm

-- testing all ---------------------------------------------------------------

    -- testing + -------------------------------------------------------------
    (+ 1 "foo") ...................................................... [ PASS]
    (+ 1 #\a) ........................................................ [ PASS]
    (+ 1 foo) ........................................................ [ PASS]
    (+ 1 #t) ......................................................... [ PASS]
    (+ 1 (lambda () 'foo)) ........................................... [ PASS]
    (+ 1 '()) ........................................................ [ PASS]
    (+ 1 '(foo . bar)) ............................................... [ PASS]
    (+ 1 '(1 2 3)) ................................................... [ PASS]
    (+ 1 '(1.0 2.0 3.0)) ............................................. [ PASS]
    (+ 1 '("a" "b" "c")) ............................................. [ PASS]
    (+ 1 '(#\a #\b #\c)) ............................................. [ PASS]
    (+ 1 '((1 2) (3 4) (5 6))) ....................................... [ PASS]
    (+ 1 '#()) ....................................................... [ PASS]
    (+ 1 '#(1 2 3)) .................................................. [ PASS]
    (+ 1 '#(1.0 2.0 3.0)) ............................................ [ PASS]
    (+ 1 '#("a" "b" "c")) ............................................ [ PASS]
    (+ 1 '#(#\a #\b #\c)) ............................................ [ PASS]
    (+ 1 '#((1 2) (3 4) (5 6))) ...................................... [ PASS]
    (+ "foo" 1) ...................................................... [ PASS]
    (+ #\a 1) ........................................................ [ PASS]
    (+ foo 1) ........................................................ [ PASS]
    (+ #t 1) ......................................................... [ PASS]
    (+ (lambda () 'foo) 1) ........................................... [ PASS]
    (+ '() 1) ........................................................ [ PASS]
    (+ '(foo . bar) 1) ............................................... [ PASS]
    (+ '(1 2 3) 1) ................................................... [ PASS]
    (+ '(1.0 2.0 3.0) 1) ............................................. [ PASS]
    (+ '("a" "b" "c") 1) ............................................. [ PASS]
    (+ '(#\a #\b #\c) 1) ............................................. [ PASS]
    (+ '((1 2) (3 4) (5 6)) 1) ....................................... [ PASS]
    (+ '#() 1) ....................................................... [ PASS]
    (+ '#(1 2 3) 1) .................................................. [ PASS]
    (+ '#(1.0 2.0 3.0) 1) ............................................ [ PASS]
    (+ '#("a" "b" "c") 1) ............................................ [ PASS]
    (+ '#(#\a #\b #\c) 1) ............................................ [ PASS]
    (+ '#((1 2) (3 4) (5 6)) 1) ...................................... [ PASS]
    36 tests completed in 0.041 seconds.
    36 out of 36 (100%) tests passed.
    -- done testing + --------------------------------------------------------


    -- testing add1 ----------------------------------------------------------
    (add1 "foo") ..................................................... [ PASS]
    (add1 #\a) ....................................................... [ PASS]
    (add1 foo) ....................................................... [ PASS]
    (add1 #t) ........................................................ [ PASS]
    (add1 (lambda () 'foo)) .......................................... [ PASS]
    (add1 '()) ....................................................... [ PASS]
    (add1 '(foo . bar)) .............................................. [ PASS]
    (add1 '(1 2 3)) .................................................. [ PASS]
    (add1 '(1.0 2.0 3.0)) ............................................ [ PASS]
    (add1 '("a" "b" "c")) ............................................ [ PASS]
    (add1 '(#\a #\b #\c)) ............................................ [ PASS]
    (add1 '((1 2) (3 4) (5 6))) ...................................... [ PASS]
    (add1 '#()) ...................................................... [ PASS]
    (add1 '#(1 2 3)) ................................................. [ PASS]
    (add1 '#(1.0 2.0 3.0)) ........................................... [ PASS]
    (add1 '#("a" "b" "c")) ........................................... [ PASS]
    (add1 '#(#\a #\b #\c)) ........................................... [ PASS]
    (add1 '#((1 2) (3 4) (5 6))) ..................................... [ PASS]
    18 tests completed in 0.017 seconds.
    18 out of 18 (100%) tests passed.
    -- done testing add1 -----------------------------------------------------


    -- testing string-join ---------------------------------------------------
    (string-join 1) .................................................. [ PASS]
    (string-join 1.0) ................................................ [ PASS]
    (string-join "foo") .............................................. [ PASS]
    (string-join #\a) ................................................ [ PASS]
    (string-join foo) ................................................ [ PASS]
    (string-join #t) ................................................. [ PASS]
    (string-join (lambda () 'foo)) ................................... [ PASS]
    (string-join '(foo . bar)) ....................................... [ PASS]
    (string-join '(1 2 3)) ........................................... [ PASS]
    (string-join '(1.0 2.0 3.0)) ..................................... [ PASS]
    (string-join '(#\a #\b #\c)) ..................................... [ PASS]
    (string-join '((1 2) (3 4) (5 6))) ............................... [ PASS]
    (string-join '#()) ............................................... [ PASS]
    (string-join '#(1 2 3)) .......................................... [ PASS]
    (string-join '#(1.0 2.0 3.0)) .................................... [ PASS]
    (string-join '#("a" "b" "c")) .................................... [ PASS]
    (string-join '#(#\a #\b #\c)) .................................... [ PASS]
    (string-join '#((1 2) (3 4) (5 6))) .............................. [ PASS]
    18 tests completed in 0.018 seconds.
    18 out of 18 (100%) tests passed.
    -- done testing string-join ----------------------------------------------


    -- testing list-ref ------------------------------------------------------
    (list-ref '(1 2 3) 1.0) .......................................... [ PASS]
    (list-ref '(1 2 3) "foo") ........................................ [ PASS]
    (list-ref '(1 2 3) #\a) .......................................... [ PASS]
    (list-ref '(1 2 3) foo) .......................................... [ PASS]
    (list-ref '(1 2 3) #t) ........................................... [ PASS]
    (list-ref '(1 2 3) (lambda () 'foo)) ............................. [ PASS]
    (list-ref '(1 2 3) '()) .......................................... [ PASS]
    (list-ref '(1 2 3) '(foo . bar)) ................................. [ PASS]
    (list-ref '(1 2 3) '(1 2 3)) ..................................... [ PASS]
    (list-ref '(1 2 3) '(1.0 2.0 3.0)) ............................... [ PASS]
    (list-ref '(1 2 3) '("a" "b" "c")) ............................... [ PASS]
    (list-ref '(1 2 3) '(#\a #\b #\c)) ............................... [ PASS]
    (list-ref '(1 2 3) '((1 2) (3 4) (5 6))) ......................... [ PASS]
    (list-ref '(1 2 3) '#()) ......................................... [ PASS]
    (list-ref '(1 2 3) '#(1 2 3)) .................................... [ PASS]
    (list-ref '(1 2 3) '#(1.0 2.0 3.0)) .............................. [ PASS]
    (list-ref '(1 2 3) '#("a" "b" "c")) .............................. [ PASS]
    (list-ref '(1 2 3) '#(#\a #\b #\c)) .............................. [ PASS]
    (list-ref '(1 2 3) '#((1 2) (3 4) (5 6))) ........................ [ PASS]
    (list-ref 1 1) ................................................... [ PASS]
    (list-ref 1.0 1) ................................................. [ PASS]
    (list-ref "foo" 1) ............................................... [ PASS]
    (list-ref #\a 1) ................................................. [ PASS]
    (list-ref foo 1) ................................................. [ PASS]
    (list-ref #t 1) .................................................. [ PASS]
    (list-ref (lambda () 'foo) 1) .................................... [ PASS]
    (list-ref '() 1) ................................................. [ PASS]
    (list-ref '(foo . bar) 1) ........................................ [ PASS]
    (list-ref '#() 1) ................................................ [ PASS]
    (list-ref '#(1 2 3) 1) ........................................... [ PASS]
    (list-ref '#(1.0 2.0 3.0) 1) ..................................... [ PASS]
    (list-ref '#("a" "b" "c") 1) ..................................... [ PASS]
    (list-ref '#(#\a #\b #\c) 1) ..................................... [ PASS]
    (list-ref '#((1 2) (3 4) (5 6)) 1) ............................... [ PASS]
    34 tests completed in 0.031 seconds.
    34 out of 34 (100%) tests passed.
    -- done testing list-ref -------------------------------------------------


    -- testing car -----------------------------------------------------------
    (car 1) .......................................................... [ PASS]
    (car 1.0) ........................................................ [ PASS]
    (car "foo") ...................................................... [ PASS]
    (car #\a) ........................................................ [ PASS]
    (car foo) ........................................................ [ PASS]
    (car #t) ......................................................... [ PASS]
    (car (lambda () 'foo)) ........................................... [ PASS]
    (car '()) ........................................................ [ PASS]
    (car '#()) ....................................................... [ PASS]
    (car '#(1 2 3)) .................................................. [ PASS]
    (car '#(1.0 2.0 3.0)) ............................................ [ PASS]
    (car '#("a" "b" "c")) ............................................ [ PASS]
    (car '#(#\a #\b #\c)) ............................................ [ PASS]
    (car '#((1 2) (3 4) (5 6))) ...................................... [ PASS]
    14 tests completed in 0.003 seconds.
    14 out of 14 (100%) tests passed.
    -- done testing car ------------------------------------------------------


    -- testing cdr -----------------------------------------------------------
    (cdr 1) .......................................................... [ PASS]
    (cdr 1.0) ........................................................ [ PASS]
    (cdr "foo") ...................................................... [ PASS]
    (cdr #\a) ........................................................ [ PASS]
    (cdr foo) ........................................................ [ PASS]
    (cdr #t) ......................................................... [ PASS]
    (cdr (lambda () 'foo)) ........................................... [ PASS]
    (cdr '()) ........................................................ [ PASS]
    (cdr '#()) ....................................................... [ PASS]
    (cdr '#(1 2 3)) .................................................. [ PASS]
    (cdr '#(1.0 2.0 3.0)) ............................................ [ PASS]
    (cdr '#("a" "b" "c")) ............................................ [ PASS]
    (cdr '#(#\a #\b #\c)) ............................................ [ PASS]
    (cdr '#((1 2) (3 4) (5 6))) ...................................... [ PASS]
    14 tests completed in 0.004 seconds.
    14 out of 14 (100%) tests passed.
    -- done testing cdr ------------------------------------------------------

6 subgroups completed in 0.114 seconds.
6 out of 6 (100%) subgroups passed.
-- done testing all ----------------------------------------------------------