├── .gitignore ├── src ├── monads.scm ├── streams.scm ├── knuth.scm ├── sicp3-3.scm ├── tmp.scm ├── test.scm ├── sicp2-3.scm ├── test-manager │ ├── mit-scheme-tests.scm │ ├── doc │ │ ├── CHANGELOG │ │ ├── testing.pod │ │ └── testing.html │ ├── load.scm │ ├── failure-report-demo.scm │ ├── checks.scm │ ├── Rakefile │ ├── guile-conditions.scm │ ├── mitscheme-conditions.scm │ ├── interactions.scm │ ├── ordered-map.scm │ ├── matching.scm │ ├── testing.scm │ ├── portability.scm │ ├── test-runner.scm │ ├── assertions.scm │ ├── test-group.scm │ ├── srfi-69-hash-tables.scm │ └── all-tests.scm ├── reasoned.scm ├── search.scm ├── kanren-book │ ├── mkextraforms.scm │ ├── mk.scm │ └── mkprelude.scm ├── data.scm ├── lil_00_test.scm ├── sicp3-1.scm ├── higher.scm ├── nested.scm ├── recur.scm ├── seq.scm ├── nine.scm └── lil_00.scm ├── README.md └── doc └── reasoned.md /.gitignore: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/monads.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; monads.scm 3 | ;; 4 | 5 | -------------------------------------------------------------------------------- /src/streams.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; streams.scm 3 | ;; 4 | 5 | (define (clist lo hi) 6 | (if (>= lo hi) nil 7 | (cons lo (clist (+ lo 1) hi)))) 8 | 9 | (clist 5 15) 10 | -------------------------------------------------------------------------------- /src/knuth.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; knuth.scm 3 | ;; 4 | 5 | ;; euclid gcd 6 | ;; 7 | (define (gcd m n) 8 | (if (zero? (modulo m n)) n 9 | (gcd n (modulo m n)))) 10 | 11 | 12 | 13 | (gcd 256 38) 14 | 15 | (trace gcd) 16 | (display "-------------") 17 | (gcd 119 544) 18 | -------------------------------------------------------------------------------- /src/sicp3-3.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; sicp3-3.scm 3 | ;; 4 | 5 | ;; 3.3.2 - queues 6 | ;; 7 | 8 | (define (make-queue) (cons ’() ’())) 9 | 10 | (define (front-ptr queue) (car queue)) 11 | (define (rear-ptr queue) (cdr queue)) 12 | 13 | (define (set-front-ptr! queue item) (set-car! queue item)) 14 | (define (set-rear-ptr! queue item) (set-cdr! queue item)) 15 | 16 | (define (empty-queue? queue) (null? (front-ptr queue))) 17 | 18 | (define q (make-queue)) 19 | 20 | (empty-queue? q) 21 | -------------------------------------------------------------------------------- /src/tmp.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; tmp.scm 3 | ;; 4 | 5 | (define (flatten xs) 6 | (define (loop accu rem) 7 | (cond ((null? rem) accu) 8 | (else (cond ((atom? (car rem)) (loop accu (cdr rem))) 9 | (else (cons (car rem) (flatten (cdr rem)))))))) 10 | (loop '() xs)) 11 | 12 | 13 | ;; flatten - if null?, return empty list 14 | ;; else, if atom?, add to accu 15 | ;; else, create list of flatten + flatten 16 | 17 | (define x (list 15 (list 3 (list 3 2 1) 9) 12)) 18 | 19 | x 20 | 21 | (flatten x) 22 | 23 | -------------------------------------------------------------------------------- /src/test.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (square x) (* x x)) 4 | 5 | (square 5) 6 | 7 | (define (sum-of-squares x y) 8 | (+ (square x) (square y))) 9 | 10 | (sum-of-squares 3 4) 11 | 12 | (define (abs x) 13 | (cond ((> x 0) x) 14 | ((= x 0) 0) 15 | ((< x 0) (- x)))) 16 | 17 | (abs 33) 18 | 19 | (define (abs x) 20 | (cond ((< x 0) (- x)) 21 | (else x))) 22 | 23 | (define (abs x) 24 | (if (< x 0) 25 | (- x) 26 | x)) 27 | 28 | 29 | 30 | 31 | 32 | (define (sqrt x) 33 | (define (isGoodEnough g) 34 | (< (abs (- x (square g))) .01)) 35 | (define (sqrt-iter g) 36 | (if (isGoodEnough g) g 37 | (sqrt-iter (/ (+ g (/ x g)) 2)))) 38 | (sqrt-iter 1)) 39 | 40 | (sqrt 9.0) 41 | -------------------------------------------------------------------------------- /src/sicp2-3.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; sicp2-3.scm 3 | ;; 4 | 5 | "------------------------------------" 6 | 7 | (define (add x y) (apply-generic ’add x y)) 8 | (define (sub x y) (apply-generic ’sub x y)) 9 | (define (mul x y) (apply-generic ’mul x y)) 10 | (define (div x y) (apply-generic ’div x y)) 11 | 12 | (define (install-scheme-number-package) 13 | (define (tag x) 14 | (attach-tag ’scheme-number x)) 15 | (put ’add ’(scheme-number scheme-number) 16 | (lambda (x y) (tag (+ x y)))) 17 | (put ’sub ’(scheme-number scheme-number) 18 | (lambda (x y) (tag (- x y)))) 19 | (put ’mul ’(scheme-number scheme-number) 20 | (lambda (x y) (tag (* x y)))) 21 | (put ’div ’(scheme-number scheme-number) 22 | (lambda (x y) (tag (/ x y)))) 23 | (put ’make ’scheme-number 24 | (lambda (x) (tag x))) 25 | ’done) 26 | 27 | (define (make-scheme-number n) 28 | ((get ’make ’scheme-number) n)) 29 | 30 | (make-scheme-number 5) 31 | -------------------------------------------------------------------------------- /src/test-manager/mit-scheme-tests.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Learning Scheme 2 | 3 | ### Summary 4 | 5 | Keeping my random hacking while learning Scheme here. 6 | 7 | ### Notes 8 | 9 | My [solutions (src/nine.scm)](https://github.com/marsmining/learn-scm/blob/master/src/nine.scm) in scheme to these [99 scala problems](http://aperiodic.net/phil/scala/s-99/). 10 | 11 | Following [The Little Schemer](http://www.amazon.com/Little-Schemer-Daniel-P-Friedman/dp/0262560992) in these [files (src/lil_00.scm)](https://github.com/marsmining/learn-scm/blob/master/src/lil_00.scm). 12 | 13 | My notes following [The Reasoned Schemer](http://www.amazon.com/Reasoned-Schemer-Daniel-P-Friedman/dp/0262562146) are [here (doc/reasoned.md)](https://github.com/marsmining/learn-scm/blob/master/doc/reasoned.md). 14 | 15 | SICP, etc found in [source dir](https://github.com/marsmining/learn-scm/tree/master/src). 16 | 17 | ### Links 18 | 19 | From ch. 8 of Little Schemer, further reading: 20 | 21 | * http://en.wikipedia.org/wiki/Continuation_passing_style 22 | * http://en.wikipedia.org/wiki/Call-with-current-continuation 23 | * http://en.wikipedia.org/wiki/Continuation -------------------------------------------------------------------------------- /src/reasoned.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; reasoned.scm - following along the reasoned schemer book 3 | ;; 4 | 5 | (load "kanren-book/mk.scm") 6 | (load "kanren-book/mkextraforms.scm") 7 | (load "kanren-book/mkprelude.scm") 8 | 9 | ;; ch. 1 10 | ;; playthings 11 | 12 | (run* 13 | (q) 14 | (== #t q)) 15 | 16 | (run* (q) 17 | (fresh (x) 18 | (== #t x) 19 | (== x q))) 20 | 21 | (run* (x) succeed) ; => (_.0) 22 | 23 | (run* (r) 24 | (fresh (x y) 25 | (== (cons x (cons y '())) r))) 26 | ;; => ((_.0 _.1)) 27 | 28 | (run* (x) 29 | (conde ((== 'olive x) succeed) 30 | ((== 'oil x) succeed))) 31 | ;; => (olive oil) 32 | 33 | (define (teacupo x) 34 | (conde ((== 'tea x) succeed) 35 | ((== 'cup x) succeed) 36 | (else fail))) 37 | 38 | (run* (x) (teacupo x)) ; => (tea cup) 39 | 40 | (run* (r) 41 | (fresh (x y) 42 | (conde ((teacupo x) (== #t y) succeed) 43 | ((== #f x) (== #t y)) 44 | (else fail)) 45 | (== (cons x (cons y '())) r))) 46 | ;; => ((tea #t) (cup #t) (#f #t)) 47 | 48 | ;; ch. 2 49 | ;; teaching old toys new tricks 50 | 51 | 52 | 53 | (restart 1) 54 | -------------------------------------------------------------------------------- /src/search.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; search.scm 3 | ;; 4 | 5 | (define binary-search 6 | (lambda (vec sought . opt) 7 | (let ((precedes? (if (null? opt) < (car opt)))) 8 | (let loop ((start 0) 9 | (stop (- (vector-length vec) 1))) 10 | (if (< stop start) 11 | #f 12 | (let* ((midpoint (quotient (+ start stop) 2)) 13 | (mid-value (vector-ref vec midpoint))) 14 | (cond ((precedes? sought mid-value) 15 | (loop start (- midpoint 1))) 16 | ((precedes? mid-value sought) 17 | (loop (+ midpoint 1) stop)) 18 | (else midpoint)))))))) 19 | 20 | (define v0 (vector 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) 21 | (define v1 (vector 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm)) 22 | 23 | v0 (binary-search v0 7) 24 | 25 | 26 | (define (bsearch vec sought) 27 | (let loop ((start 0) (stop (-1+ (vector-length vec)))) 28 | (if (< stop start) -1 29 | (let* ((midpoint (quotient (+ start stop) 2)) 30 | (midvalue (vector-ref vec midpoint))) 31 | (cond ((< sought midvalue) (loop start (-1+ midpoint))) 32 | ((< midvalue sought) (loop (1+ midpoint) stop)) 33 | (else midpoint)))))) 34 | 35 | (bsearch v0 7) 36 | 37 | -------------------------------------------------------------------------------- /src/kanren-book/mkextraforms.scm: -------------------------------------------------------------------------------- 1 | ;;; Code that accompanies ``The Reasoned Schemer'' 2 | ;;; Daniel P. Friedman, William E. Byrd and Oleg Kiselyov 3 | ;;; MIT Press, Cambridge, MA, 2005 4 | ;;; 5 | ;;; Extra forms appearing in the framenotes of the book. 6 | ;;; 7 | ;;; run* is a convenient macro (see frame 10 on page 4 of chapter 1) 8 | ;;; (run* (q) ...) is identical to (run #f (q) ...) 9 | ;;; See frame 40 on page 68 of chapter 5 for a description of 'lambda-limited'. 10 | ;;; See frame 47 on page 138 of chapter 9 for a description of 'project'. 11 | ;;; 12 | ;;; This file was generated by writeminikanren.pl 13 | ;;; Generated at 2005-08-12 11:27:16 14 | 15 | (define-syntax run* 16 | (syntax-rules () 17 | ((_ (x) g ...) (run #f (x) g ...)))) 18 | 19 | (define-syntax lambda-limited 20 | (syntax-rules () 21 | ((_ n formals g) 22 | (let ((x (var 'x))) 23 | (lambda formals 24 | (ll n x g)))))) 25 | 26 | (define ll 27 | (lambda (n x g) 28 | (lambdag@ (s) 29 | (let ((v (walk x s))) 30 | (cond 31 | ((var? v) (g (ext-s x 1 s))) 32 | ((< v n) (g (ext-s x (+ v 1) s))) 33 | (else (fail s))))))) 34 | 35 | (define-syntax project 36 | (syntax-rules () 37 | ((_ (x ...) g ...) 38 | (lambdag@ (s) 39 | (let ((x (walk* x s)) ...) 40 | ((all g ...) s)))))) 41 | -------------------------------------------------------------------------------- /src/data.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; data.scm 3 | ;; 4 | 5 | (define (yell n) 6 | (if (= n 0) "hiya" 7 | (string-append (yell (- n 1)) "a"))) 8 | 9 | (yell 5) 10 | 11 | ;; rational numbers 12 | 13 | (define (make-rat n d) (cons n d)) 14 | (define (numer x) (car x)) 15 | (define (denom x) (cdr x)) 16 | 17 | (define (add-rat x y) 18 | (make-rat (+ (* (numer x) (denom y)) 19 | (* (numer y) (denom x))) 20 | (* (denom x) (denom y)))) 21 | 22 | (define (sub-rat x y) 23 | (make-rat (- (* (numer x) (denom y)) 24 | (* (numer y) (denom x))) 25 | (* (denom x) (denom y)))) 26 | 27 | (define (mul-rat x y) 28 | (make-rat (* (numer x) (numer y)) 29 | (* (denom x) (denom y)))) 30 | 31 | (define (div-rat x y) 32 | (make-rat (* (numer x) (denom y)) 33 | (* (denom x) (numer y)))) 34 | 35 | (define (equal-rat? x y) 36 | (= (* (numer x) (denom y)) 37 | (* (numer y) (denom x)))) 38 | 39 | (define one-half (make-rat 1 2)) 40 | (print-rat one-half) 41 | 42 | ;; cons, car, cdr 43 | 44 | (define (cons x y) 45 | (define (dispatch m) 46 | (cond ((= m 0) x) 47 | ((= m 1) y) 48 | (else (error "Argument not 0 or 1 - CONS" m)))) 49 | dispatch) 50 | (define (car z) (z 0)) 51 | (define (cdr z) (z 1)) 52 | 53 | (define (cons x y) 54 | (lambda (m) (m x y))) 55 | (define (car z) 56 | (z (lambda (p q) p))) 57 | (define (cdr z) 58 | (z (lambda (p q) q))) 59 | 60 | (define hmm (cons 11 12)) 61 | (define hmmm (cons 11 12)) 62 | 63 | (cdr hmm) 64 | 65 | -------------------------------------------------------------------------------- /src/lil_00_test.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; lil_00_test.scm - schemer tests 3 | ;; 4 | 5 | (load "test-manager/load.scm") 6 | (load "lil_00.scm") 7 | 8 | (in-test-group 9 | schemer 10 | 11 | ;; null? 12 | (define-test (null-tests) 13 | "Checking that 'null?' works" 14 | (check (null? '()) "Empty list is null") 15 | (check (not (null? (list 'a 'b))) "Non-empty list is not null")) 16 | 17 | (define-test (atom-tests) 18 | "Checking that 'atom?' works" 19 | (check (atom? 'fred) "String 'fred' is an atom") 20 | (check (atom? 43) "Number '43' is an atom") 21 | (check (not (atom? '())) "Empty list is not an atom") 22 | (check (not (atom? (list 43 67))) "List '(43 67)' is not an atom")) 23 | 24 | (define-test (lat-tests) 25 | "Checking that 'lat?' works" 26 | (check (lat? '()) "True for empty list") 27 | (check (lat? (list 'fred 'wilma)) "List '(fred wilma)' is true") 28 | (check (not (lat? (list 'fred (list 'wilma 'barney)))) "List '(fred (wilma barney))' is false")) 29 | 30 | (define-test (member-rember-tests) 31 | "Checking that 'member?' and 'rember' works" 32 | (check (member? 'c '(x y a b c y))) 33 | (check (not (member? 'g '(x y a b c y)))) 34 | (check (list-equal? (rember 'z '(x y z a)) '(x y a))) 35 | (check (list-equal? (rember 'g '(x y z a)) '(x y z a)))) 36 | 37 | (define-test (list-equal-tests) 38 | "Checking if 'list-equal?' works" 39 | (check (list-equal? '() '())) 40 | (check (list-equal? '(a b c) '(a b c))) 41 | (check (not (list-equal? '(b) '(a))))) 42 | 43 | (run-registered-tests)) 44 | 45 | -------------------------------------------------------------------------------- /src/sicp3-1.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; sicp3-1.scm 3 | ;; 4 | 5 | "---------------------------------------------" 6 | 7 | (define balance 400) 8 | 9 | (set! balance 300) 10 | 11 | balance 12 | 13 | (define new-withdraw 14 | (let ((balance 100)) 15 | (lambda (amount) 16 | (if (>= balance amount) 17 | (begin (set! balance (- balance amount)) 18 | balance) 19 | "Insufficient funds")))) 20 | 21 | (define wd (new-withdraw 59)) 22 | 23 | (define (make-account balance) 24 | (define (withdraw amount) 25 | (if (>= balance amount) 26 | (begin (set! balance (- balance amount)) 27 | balance) 28 | "Insufficient funds")) 29 | (define (deposit amount) 30 | (set! balance (+ balance amount)) 31 | balance) 32 | (define (dispatch m) 33 | (cond ((eq? m 'withdraw) withdraw) 34 | ((eq? m 'deposit) deposit) 35 | (else (error "Unknown request - MAKE-ACCOUNT" 36 | m)))) 37 | dispatch) 38 | 39 | (define acct (make-account 50)) 40 | 41 | ((acct 'deposit) 50) 42 | 43 | (define (make-accumulator n) 44 | (let ((accu n)) 45 | (lambda (x) 46 | (begin (set! accu (+ x accu)) accu)))) 47 | 48 | (define A (make-accumulator 5)) 49 | 50 | (A 10) 51 | (A 10) 52 | 53 | ;; exercise 3.2 54 | ;; 55 | (define (sq n) (* n n)) 56 | (define (make-monitored f) 57 | (let ((cnt 0)) 58 | (lambda (arg) 59 | (cond ((number? arg) 60 | (set! cnt (+ cnt 1)) 61 | (apply f (list arg))) 62 | ((eq? arg 'how-many-calls?) 63 | cnt) 64 | (else "unkown req"))))) 65 | 66 | (define s (make-monitored sq)) 67 | 68 | (s 100) 69 | 70 | (s 'how-many-calls?) 71 | 72 | ;; 73 | -------------------------------------------------------------------------------- /src/higher.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; higher.scm 3 | ;; 4 | 5 | ;; fold left - uses an accumulator loop, where we keep 6 | ;; track of 'result' which starts at 'initial' and 'rest' 7 | ;; which starts at 'sequence'. Each iteration, 'result' 8 | ;; becomes 'op result head' and 'rest' becomes 'tail'. 9 | ;; 10 | ;; (op initial head) 11 | ;; 12 | (define (fold-left op initial sequence) 13 | (define (iter result rest) 14 | (if (null? rest) 15 | result 16 | (iter (op result (car rest)) 17 | (cdr rest)))) 18 | (iter initial sequence)) 19 | 20 | ;; fold right - calls the 'op' operator with args 'head' 21 | ;; and recursive call to 'fold-right' with 'tail'. 22 | ;; 23 | ;; (op head initial) 24 | ;; 25 | ;; eg: call 'fold-right' 'fr'.. 26 | ;; (fr + 0 (list 1 2 3)) 27 | ;; (+ head (fr + 0 (2 3))) 28 | ;; (+ 1 (+ 2 (fr + 0 (3)))) 29 | ;; (+ 1 (+ 2 (+ 3 (fr + 0 ())))) 30 | ;; (+ 1 (+ 2 (+ 3 0))) 31 | ;; 32 | (define (fold-right op initial sequence) 33 | (if (null? sequence) 34 | initial 35 | (op (car sequence) 36 | (fold-right op initial (cdr sequence))))) 37 | 38 | 39 | (define nil '()) 40 | 41 | (fold-right / 1 (list 1 2 3)) 42 | (fold-left / 1 (list 1 2 3)) 43 | (fold-right list nil (list 1 2 3)) 44 | (fold-left list nil (list 1 2 3)) 45 | 46 | (fold-right + 0 (list 1 2 3)) 47 | (+ 1 (+ 2 (+ 3 0))) 48 | 49 | (define (append xs ys) 50 | (if (null? xs) ys 51 | (cons (car xs) (append (cdr xs) ys)))) 52 | 53 | (append (list 1 2 3) (list 4 5 6)) 54 | 55 | (define (reverse sequence) 56 | (fold-right (lambda (x xs) (append xs (list x))) nil sequence)) 57 | 58 | (define (reverse sequence) 59 | (fold-left (lambda (xs x) (cons x xs)) nil sequence)) 60 | 61 | (reverse (list 1 2 3)) 62 | 63 | -------------------------------------------------------------------------------- /src/test-manager/doc/CHANGELOG: -------------------------------------------------------------------------------- 1 | From 1.1 to 1.2: 2 | - Official support for Guile dropped. Most everything should still 3 | work. I don't know how hard the rest is to port. 4 | - There is now a check macro that is largely meant to replace the 5 | assert-foo procedures. 6 | - Also define-each-check, which is a combination of define-each-test 7 | and check 8 | - The notion of "matching" is now extensible via the generic (in the 9 | sense of SOS) procedure generic-match. Default methods are provided 10 | for general objects, vectors, lists, and floating-point numbers, as 11 | well as interpreting string patterns as regular expressions. 12 | (MIT Scheme only) 13 | - There is now an interaction macro for writing tests that look 14 | like REPL sessions. It does with a produces procedure that refers 15 | to the value of the last evaluated form, and works within calls to 16 | the interaction macro and at the REPL (REPL is MIT Scheme only). 17 | - Assertions assert-< assert-> assert-<= assert->= added 18 | - It is now an intentional, supported feature that you can use 19 | a delayed expression in the assertion failure message position 20 | to do arbitrary computation if the assertion fails. The return 21 | value of said computation will be printed as an additional message 22 | in the failure report; and the suite will not crash even if that 23 | value fails to be a string. 24 | - There is now a clear-registered-tests! procedure for interactive use. 25 | 26 | From 1.0 to 1.1: 27 | 28 | - You can now use promises (made by delay) as assertion failure 29 | messages. If the message is a promise, the framework will only 30 | force it if the assertion fails. 31 | - Added assert-no-match to complement assert-matches. 32 | - Tests now understand docstrings, meaning they print them if the test 33 | fails. Single-form tests use the test form itself as the docstring. 34 | - Added define-each-test to make single-form tests out of each of its 35 | argument expressions. This is a convenience over writing 36 | (define-test (assert-foo ... )) over and over. 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/test-manager/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; load-relative, broken in Guile, depends on MIT Scheme's pathname 21 | ;; system. 22 | ;; TODO Fix for interactive use? 23 | (cond-expand 24 | (guile 25 | (if (defined? 'load-relative) 26 | 'ok 27 | (define (load-relative filename) 28 | ;; Guile's load appears to magically do the right thing... 29 | (load (string-concatenate (list filename ".scm")))))) 30 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 31 | (define (load-relative filename) 32 | (with-working-directory-pathname 33 | (directory-namestring (current-load-pathname)) 34 | (lambda () (load filename)))))) 35 | 36 | (load-relative "portability") 37 | (load-relative "ordered-map") 38 | (load-relative "matching") 39 | (load-relative "assertions") 40 | (load-relative "test-runner") 41 | (load-relative "test-group") 42 | (load-relative "testing") 43 | (load-relative "checks") 44 | (load-relative "interactions") 45 | 46 | ;; MIT Scheme specific features 47 | (cond-expand 48 | (guile 49 | 'ok) 50 | (else 51 | 'ok)) 52 | -------------------------------------------------------------------------------- /src/nested.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; nested.scm 3 | ;; 4 | 5 | ;; foo lib 6 | ;; 7 | 8 | (define (range a b) 9 | (if (= a b) '() 10 | (cons a (range (+ a 1) b)))) 11 | 12 | (define nil '()) 13 | 14 | (define (enumerate-tree tree) 15 | (cond ((null? tree) '()) 16 | ((not (pair? tree)) (list tree)) 17 | (else (append (enumerate-tree (car tree)) 18 | (enumerate-tree (cdr tree)))))) 19 | 20 | (define (flatmap proc seq) 21 | (fold-right append nil (map proc seq))) 22 | 23 | (define (smallest-divisor n) 24 | (find-divisor n 2)) 25 | 26 | (define (find-divisor n test-divisor) 27 | (cond ((> (square test-divisor) n) n) 28 | ((divides? test-divisor n) test-divisor) 29 | (else (find-divisor n (+ test-divisor 1))))) 30 | 31 | (define (divides? a b) 32 | (= (remainder b a) 0)) 33 | 34 | (define (prime? n) 35 | (= n (smallest-divisor n))) 36 | 37 | (define (square n) (* n n)) 38 | 39 | ;; nested sicp 40 | ;; 41 | 42 | (define (combos n) 43 | (flatmap (lambda (i) 44 | (map (lambda (j) (list i j)) 45 | (range 1 i))) 46 | (range 1 (+ n 1)))) 47 | 48 | (define (prime-sum? pair) 49 | (prime? (+ (car pair) (cadr pair)))) 50 | 51 | (define (make-pair-sum pair) 52 | (list (car pair) (cadr pair) (+ (car pair) (cadr pair)))) 53 | 54 | (define (prime-sum-pairs n) 55 | (map make-pair-sum 56 | (filter prime-sum? 57 | (combos n)))) 58 | 59 | (combos 6) 60 | 61 | (prime-sum-pairs 6) 62 | 63 | ;; permutations 64 | ;; 65 | 66 | (define (remove item sequence) 67 | (filter (lambda (x) (not (= x item))) 68 | sequence)) 69 | 70 | (define (permutations s) 71 | (if (null? s) ; emptyset? 72 | (list nil) ; sequence containing emptyset 73 | (flatmap (lambda (x) 74 | (map (lambda (p) (cons x p)) 75 | (permutations (remove x s)))) 76 | s))) 77 | 78 | ;; forech item, cons item with each set of permutations 79 | ;; of the set minus the current item, so, we get eg: 80 | ;; 81 | ;; 2-4: (2 4) (4 2) 82 | ;; 2-6: (2 6) (6 2) 83 | ;; 4-6: (4 6) (6 4) 84 | ;; 85 | (permutations (list 2 4 6)) 86 | (permutations (list 2 4)) 87 | 88 | 89 | -------------------------------------------------------------------------------- /doc/reasoned.md: -------------------------------------------------------------------------------- 1 | ## Notes while reading "The Reasoned Schemer" 2 | 3 | ### Summary 4 | 5 | My notes following [The Reasoned Schemer](http://www.amazon.com/Reasoned-Schemer-Daniel-P-Friedman/dp/0262562146). Code is [here (src/reasoned.scm)](https://github.com/marsmining/learn-scm/blob/master/src/reasoned.scm). Using MIT/GNU Scheme 9.1.1. 6 | 7 | Using [Byrd's dissertation](https://scholarworks.iu.edu/dspace/bitstream/handle/2022/8777/Byrd_indiana_0093A_10344.pdf) as well to help understanding. 8 | 9 | Also this [youtube series](http://www.youtube.com/watch?v=vRrgaibcTYs), all of which is totally over my head atm. 10 | 11 | ### Preface 12 | 13 | This is my second try reading this book. My first attempt ended maybe a quarter of the way through. I found it hard because a lot of the code was not like that of [The Little Schemer](http://www.amazon.com/Little-Schemer-Daniel-P-Friedman/dp/0262560992) where you could incrementally run the code. Or maybe I was doing something wrong. Since my first attempt, I've gone back and re-read the latter chapters of [The Little Schemer](http://www.amazon.com/Little-Schemer-Daniel-P-Friedman/dp/0262560992) more meticulously. 14 | 15 | ### Ch. 1 - Playthings 16 | 17 | Ok so we're introduced to this `run*` fn or macro. 18 | 19 | ```scheme 20 | (run 21 | #f ; not sure what this is.. ok it's the num results 22 | (q) ; logic variable 23 | (== #t q) ; goal, unify true with query 24 | ) ; => (#t) returns one answer 25 | ``` 26 | 27 | Then we're introduced to `fresh` which looks like `let`. Again, can't run any code :(. I know this book has something to do with [miniKanren](https://github.com/miniKanren/miniKanren), so gonna try to use that to run the code the book is introducing. Wait, seems book is based on Kanren, and seems co-author Oleg maintains code from book here: http://kanren.sourceforge.net/ 28 | 29 | So grabbing code from there, we can do: 30 | 31 | ```scheme 32 | (load "kanren-book/mk.scm") 33 | (load "kanren-book/mkextraforms.scm") 34 | (load "kanren-book/mkprelude.scm") 35 | 36 | (run* 37 | (q) 38 | (== #t q)) ; => (#t) 39 | ``` 40 | 41 | And it works! Can run the examples now while reading. 42 | 43 | -------------------------------------------------------------------------------- /src/test-manager/failure-report-demo.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-test (this-test-passes) 21 | (assert-eqv 4 (+ 2 2) "Two plus two isn't four.")) 22 | 23 | (define-test (this-test-fails) 24 | (assert-eqv 5 (+ 2 2) "Two plus two isn't five.")) 25 | 26 | (in-test-group 27 | a-test-group 28 | (define-test (happy-internal-test) 29 | (assert-= 12 (* 3 4) "Three by four should be twelve")) 30 | (define-test (unhappy-internal-test) 31 | (assert-equal '() #f "Nil and false are different")) 32 | (define-test (broken-internal-test) 33 | (foo)) 34 | (let ((this-test-group *current-test-group*)) 35 | (define-test (meta-internal-test) 36 | (assert-equal '(happy-internal-test unhappy-internal-test 37 | broken-internal-test 38 | meta-internal-test) 39 | (omap:key-list (tg:test-map this-test-group)))))) 40 | 41 | (in-test-group 42 | failed-assertion-showcase 43 | (define-test (fail-generic-assert-equivalent) 44 | ((assert-equivalent (lambda (x y) 45 | (or (eq? x y) 46 | (and (list? x) 47 | (list? y))))) 48 | #(a) #(f)))) 49 | 50 | (define-test (this-test-errors) 51 | (assert-eqv 4 (+ 2 (/ 2 0)) "Don't divide by zero.")) 52 | 53 | (define-test 54 | (error "Anonymous tests can fail too")) 55 | 56 | (define-test (check-smoke) 57 | (check (< (+ 2 5) (* 3 2)) "There is a check macro that tries to DWIM.")) 58 | 59 | (define-test (check-error) 60 | (check (error "Errors can happen in checks."))) 61 | 62 | (run-registered-tests) 63 | -------------------------------------------------------------------------------- /src/test-manager/checks.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (cond-expand 21 | (guile 22 | (define-macro (check assertion) 23 | (if (list? assertion) 24 | (compute-check-form assertion "" #f) 25 | `(assert-true assertion)))) 26 | (else 27 | (define-syntax check 28 | (sc-macro-transformer 29 | (lambda (form env) 30 | (let ((assertion (cadr form)) 31 | (message (if (null? (cddr form)) "" (caddr form)))) 32 | (if (list? assertion) 33 | (compute-check-form assertion message env) 34 | `(assert-true ,(close-syntax assertion env) 35 | ,(close-syntax message env))))))))) 36 | 37 | (define (compute-check-form assertion message env) 38 | (define (wrap form) 39 | (close-syntax form env)) 40 | (let loop ((bindings '()) 41 | (names '()) 42 | (assertion-left assertion)) 43 | (if (null? assertion-left) 44 | `(let ,bindings 45 | (assert-proc 46 | (better-message 47 | (list ,@(reverse names)) ',assertion ,(wrap message)) 48 | (lambda () ,(reverse names)))) 49 | (let ((fresh-name (generate-uninterned-symbol))) 50 | (loop (cons (list fresh-name (wrap (car assertion-left))) 51 | bindings) 52 | (cons fresh-name names) 53 | (cdr assertion-left)))))) 54 | 55 | (define (better-message values quoted-form message) 56 | (build-message 57 | message 58 | '("Form : " "\nArg values: " "\n") 59 | quoted-form 60 | (cdr values))) ; cdr avoids the value of the operator 61 | 62 | (define-syntax check-all 63 | (syntax-rules () 64 | ((check-all form ...) 65 | (begin (check form) ...)))) 66 | -------------------------------------------------------------------------------- /src/test-manager/Rakefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2007-2008 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of Test Manager. 5 | ### 6 | ### Test Manager is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU General Public License as published by 8 | ### the Free Software Foundation, either version 3 of the License, or 9 | ### (at your option) any later version. 10 | ### 11 | ### Test Manager is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU General Public License 17 | ### along with Test Manager. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | # -*- ruby-mode -*- 21 | 22 | require 'rake' 23 | 24 | task :default => :test 25 | 26 | desc "Run the full test suite in MIT Scheme and Guile" 27 | task :test => [ :mit_scheme_test, :guile_test ] 28 | 29 | desc "Run the full test suite in MIT Scheme" 30 | task :mit_scheme_test do 31 | sh %Q{mit-scheme --batch-mode --eval "(set! load/suppress-loading-message? #t)" --load load.scm --load all-tests.scm --eval "(%exit (run-registered-tests))"} 32 | end 33 | 34 | desc "Run the full test suite in Guile" 35 | task :guile_test do 36 | sh %Q{guile -l load.scm -l all-tests.scm -c "(exit (run-registered-tests))"} 37 | end 38 | 39 | desc "Run a demonstration test suite to show off failure reports in MIT Scheme" 40 | task :demo do 41 | sh %Q{mit-scheme --batch-mode --eval "(set! load/suppress-loading-message? #t)" --load load.scm --load failure-report-demo.scm --eval "(%exit 0)"} 42 | end 43 | 44 | desc "Run a demonstration test suite to show off failure reports in Guile" 45 | task :guile_demo do 46 | sh %Q{guile -l load.scm -l failure-report-demo.scm -c "(exit 0)"} 47 | end 48 | 49 | desc "Generate html documentation" 50 | task :doc do 51 | sh "cd #{File.dirname(__FILE__)}/doc/; cat testing.pod | pod2html > testing.html" 52 | end 53 | 54 | desc "Delete random temporary files that arise as one works" 55 | task :clean do 56 | sh "cd #{File.dirname(__FILE__)}; find . -name '*~' | xargs rm -f; find . -name 'actions.log' | xargs rm -f; find . -name 'pod2htm*.tmp' | xargs rm -f; " 57 | end 58 | 59 | desc "Prepare a release tarball" 60 | task :release => [:doc, :clean] do 61 | sh "cd #{File.dirname(__FILE__)}; " + %Q{tar --create --verbose --file ../test-manager-1.2.tar --directory .. --exclude="*.svn*" --exclude=.commitmail --exclude=todo.txt test-manager/} 62 | end 63 | -------------------------------------------------------------------------------- /src/test-manager/guile-conditions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; I apologize to the reader for this horrible collection of hacks, 21 | ;;; but Guile appears to lack a condition system worth the name, so I 22 | ;;; am synthesizing one with exactly (read: only) the characteristics 23 | ;;; I need on top of catch-throw. 24 | 25 | (define-record-type condition 26 | (make-condition type throw-args continuation) 27 | condition? 28 | (type condition/type) 29 | (throw-args condition/throw-args) 30 | (continuation condition/continuation)) 31 | 32 | (define (condition/test-failure? condition) 33 | (eq? 'test-failure (condition/type condition))) 34 | 35 | (define (condition/error? condition) 36 | (not (condition/test-failure? condition))) 37 | 38 | (define (test-fail message) 39 | (throw 'test-failure "test-fail" message #f)) 40 | 41 | (define (capture-unhandled-errors thunk) 42 | "Run the given thunk. If it returns normally, return its return 43 | value. If it signals an error, return an object representing that 44 | error instead." 45 | (let ((error-object #f)) 46 | (catch 47 | #t 48 | thunk 49 | (lambda (key . args) 50 | error-object) 51 | (lambda (key . args) 52 | (call-with-current-continuation 53 | (lambda (thrown-at) 54 | (set! error-object 55 | (make-condition key args thrown-at)))))))) 56 | 57 | (define (write-condition-report condition port) 58 | (define (extract-message throw-arguments) 59 | ;; TODO This relies on the arguments following Guile's throwing 60 | ;; convention. 61 | (let ((message-template (cadr throw-arguments)) 62 | (template-parameters (caddr throw-arguments))) 63 | (if template-parameters 64 | (apply format #f message-template template-parameters) 65 | message-template))) 66 | (display (extract-message (condition/throw-args condition)) port)) 67 | -------------------------------------------------------------------------------- /src/recur.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; recur.scm 3 | ;; 4 | 5 | (define (factorial n) 6 | (if (= n 1) 1 7 | (* n (factorial (- n 1))))) 8 | 9 | (define (factorial n) 10 | (define (iter product counter) 11 | (println "iter=" counter ", product=" product) 12 | (if (> counter n) 13 | product 14 | (iter (* counter product) (+ counter 1)))) 15 | (iter 1 1)) 16 | 17 | (factorial 6) 18 | 19 | (define (fib n) 20 | (cond ((= n 0) 0) 21 | ((= n 1) 1) 22 | (else (+ (fib (- n 1)) 23 | (fib (- n 2)))))) 24 | 25 | (define (fib n) 26 | (define (fib-iter a b count) 27 | (if (= count 0) 28 | b 29 | (fib-iter (+ a b) a (- count 1)))) 30 | (fib-iter 1 0 n)) 31 | 32 | (fib 90) 33 | 34 | ;; count change 35 | 36 | (define (count-change amount) 37 | (cc amount 5)) 38 | (define (cc amount kinds-of-coins) 39 | (println "a=" amount ", k=" kinds-of-coins) 40 | (cond ((= amount 0) 1) 41 | ((or (< amount 0) (= kinds-of-coins 0)) 0) 42 | (else (+ (cc amount 43 | (- kinds-of-coins 1)) 44 | (cc (- amount 45 | (first-denomination kinds-of-coins)) 46 | kinds-of-coins))))) 47 | (define (first-denomination kinds-of-coins) 48 | (cond ((= kinds-of-coins 1) 1) 49 | ((= kinds-of-coins 2) 5) 50 | ((= kinds-of-coins 3) 10) 51 | ((= kinds-of-coins 4) 25) 52 | ((= kinds-of-coins 5) 50))) 53 | 54 | (count-change 4) 55 | 56 | ;; exponentiation 57 | 58 | ;; recursive 59 | (define (exp b n) 60 | (if (= n 0) 1 61 | (* b (exp b (- n 1))))) 62 | 63 | ;; iterative 64 | (define (exp b n) 65 | (define (loop accu n) 66 | (if (= n 0) accu 67 | (loop (* b accu) (- n 1)))) 68 | (loop 1 n)) 69 | 70 | (exp 2 10) 71 | 72 | (define (fast-expt b n) 73 | (cond ((= n 0) 1) 74 | ((even? n) (square (fast-expt b (/ n 2)))) 75 | (else (* b (fast-expt b (- n 1)))))) 76 | 77 | (define (even? n) 78 | (= (remainder n 2) 0)) 79 | 80 | (define (square x) (* x x)) 81 | 82 | (fast-expt 2 10) 83 | 84 | ;; gcd 85 | 86 | (define (gcd a b) 87 | (if (= b 0) a 88 | (gcd b (remainder a b)))) 89 | 90 | (gcd 206 40) 91 | 92 | ;; primes 93 | 94 | (define (smallest-divisor n) 95 | (find-divisor n 2)) 96 | (define (find-divisor n test-divisor) 97 | (cond ((> (square test-divisor) n) n) 98 | ((divides? test-divisor n) test-divisor) 99 | (else (find-divisor n (+ test-divisor 1))))) 100 | (define (divides? a b) 101 | (= (remainder b a) 0)) 102 | (define (prime? n) 103 | (= n (smallest-divisor n))) 104 | 105 | (newline) 106 | 107 | ;; higher order 108 | 109 | (define inc (lambda (x) (+ x 1))) 110 | 111 | (inc 5) 112 | 113 | ;; f (x, y) = x(1 + xy)2 + y(1 − y) + (1 + xy)(1 − y) 114 | 115 | (define (fn x y) 116 | (let ((a (+ 1 (* x y))) 117 | (b (- 1 y))) 118 | (+ (* x (square a)) 119 | (* y b) 120 | (* a b)))) 121 | 122 | (fn 3 5) 123 | -------------------------------------------------------------------------------- /src/test-manager/mitscheme-conditions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; These are the definitions that are actively intertwined with MIT 21 | ;;; Scheme's condition system, which this test manager originally 22 | ;;; used. They are replaced by equivalent (I hope) domain-specific 23 | ;;; definitions tailored for other condition systems in other 24 | ;;; *-conditions.scm files. 25 | 26 | (define condition-type:test-failure 27 | (make-condition-type 'test-failure condition-type:error 28 | '(message) (lambda (condition port) 29 | (display (access-condition condition 'message) port)))) 30 | 31 | (define condition/test-failure? 32 | (condition-predicate condition-type:test-failure)) 33 | 34 | (define test-fail 35 | (condition-signaller condition-type:test-failure 36 | '(message) standard-error-handler)) 37 | 38 | ;;; Gaah! The signaling of a condition in a flexible language like 39 | ;;; Scheme does not, unlike the raising of an exception in Java, 40 | ;;; entail that the code signaling the condition failed. In fact, it 41 | ;;; is quite possible that the condition will be handled by some 42 | ;;; toplevel condition handler in a manner that will cause the 43 | ;;; underlying code to continue, and eventually produce a normal 44 | ;;; return. For example, Mechanics allows vectors to be applied by 45 | ;;; just such a mechanism. The unit test framework must, 46 | ;;; consequently, try its best to allow such shenanigans to succeed, 47 | ;;; without disrupting the operation of the test framework itself. 48 | ;;; Hence the ugliness below. 49 | ;;; TODO Port this crap to Guile 50 | (define (capture-unhandled-errors thunk) 51 | (if standard-error-hook 52 | ;; Fix this for the test-within-a-test case. 53 | (warn "If the standard error hook is already bound, I can't be sure which errors are unhandled.")) 54 | (call-with-current-continuation 55 | (lambda (k) 56 | (fluid-let ((standard-error-hook k)) 57 | (thunk))))) 58 | -------------------------------------------------------------------------------- /src/test-manager/interactions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; This is an MIT-Scheme specific facility for faking out the repl 21 | ;;; history in tests. For example: 22 | ;; (define-test (interactions) 23 | ;; (interaction 24 | ;; (define foo 5) 25 | ;; (+ foo 2) 26 | ;; (produces 7))) 27 | ;;; will actually verify that (+ foo 2) produces 7 (using the 28 | ;;; generic-match facility). Furthermore, the entire body of the 29 | ;;; (interaction ...) form can be copied into a repl wholesale, and 30 | ;;; will retain the same effect. This relies on fluid-rebinding 31 | ;;; the (out) procedure provided by MIT Scheme. 32 | 33 | (cond-expand 34 | (guile 35 | (define-macro (interaction . subforms) 36 | (compute-interaction-form subforms))) 37 | (else 38 | (define-syntax interaction 39 | (sc-macro-transformer 40 | (lambda (form use-env) 41 | (compute-interaction-form (cdr form))))))) 42 | 43 | (define (compute-interaction-form subforms) 44 | (let ((history-name (make-synthetic-identifier 'history))) 45 | `(let ((,history-name (make-interaction-history))) 46 | (fluid-let ((out (read-interaction ,history-name))) 47 | ,@(map (attach-history-tracking history-name) subforms) 48 | (cadr ,history-name))))) 49 | 50 | (define (attach-history-tracking history-name) 51 | (lambda (subform) 52 | (if (apparent-definition? subform) 53 | subform 54 | `(record-interaction ,subform ,history-name)))) 55 | 56 | (define (apparent-definition? form) 57 | (and (pair? form) 58 | (symbol? (car form)) 59 | (string-search-forward "define" (symbol->string (car form))))) 60 | 61 | (define (make-interaction-history) 62 | (list '*interaction-history*)) 63 | 64 | (define (record-interaction thing history) 65 | (set-cdr! history (cons thing (cdr history)))) 66 | 67 | (define (read-interaction history) 68 | (lambda args 69 | (let-optional args ((index 1)) 70 | (list-ref (cdr history) (- index 1))))) 71 | 72 | (define (produces pattern) 73 | (check (generic-match pattern (out)))) 74 | -------------------------------------------------------------------------------- /src/seq.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; seq.scm 3 | ;; 4 | 5 | (define seq (cons 1 (cons 2 (cons 3 (cons 4 '()))))) 6 | 7 | (list 1 2 3 4 5 6) 8 | 9 | ;; range recursive 10 | (define (range a b) 11 | (define (iter n) 12 | (if (= n b) '() 13 | (cons n (iter (+ n 1))))) 14 | (iter a)) 15 | 16 | ;; find recursive 17 | (define (find xs n) 18 | (if (= n 0) (car xs) 19 | (find (cdr xs) (- n 1)))) 20 | 21 | ;; length recursive 22 | (define (len xs) 23 | (if (null? xs) 0 24 | (+ (len (cdr xs)) 1))) 25 | 26 | ;; length iterative 27 | (define (len-iter xs) 28 | (define (loop ys accu) 29 | (if (null? ys) accu 30 | (loop (cdr ys) (+ accu 1)))) 31 | (loop xs 0)) 32 | 33 | (find (range 0 100) 99) 34 | 35 | (len seq) 36 | 37 | (len-iter (range 33 66)) 38 | 39 | ;; append two lists 40 | (define (append xs ys) 41 | (if (null? xs) ys 42 | (cons (car xs) (append (cdr xs) ys)))) 43 | 44 | 45 | (append (range 20 30) seq) 46 | 47 | (define (mymap xs fn) 48 | (if (null? xs) '() 49 | (cons (fn (car xs)) (mymap (cdr xs) fn)))) 50 | 51 | (define (sq n) (* n n)) 52 | 53 | (map (range 0 5) (lambda (n) (+ n n))) 54 | 55 | (define (isEqual xs ys) 56 | (cond ((null? xs) (null? ys)) 57 | ((null? ys) (null? xs)) 58 | ((= (car xs) (car ys)) (isEqual (cdr xs) (cdr ys))) 59 | (else (= 1 0)))) 60 | 61 | (isEqual (range 0 4) (list 1 2 3 4)) 62 | 63 | ;; trees 64 | 65 | (define x (cons (list 1 2) (range 3 8))) 66 | 67 | (define (count-leaves xs) 68 | (cond ((null? xs) 0) 69 | ((not (pair? xs)) 1) 70 | (else 71 | (+ (count-leaves (car xs)) 72 | (count-leaves (cdr xs)))))) 73 | 74 | (count-leaves x) 75 | 76 | (define (tree-map xs fn) 77 | (cond ((null? xs) '()) 78 | ((not (pair? xs)) (fn xs)) 79 | (else 80 | (cons (tree-map (car xs) fn) 81 | (tree-map (cdr xs) fn))))) 82 | 83 | (tree-map x (lambda (n) (* n n))) 84 | 85 | ;; filter 86 | 87 | (define (filter predicate sequence) 88 | (cond ((null? sequence) '()) 89 | ((predicate (car sequence)) 90 | (cons (car sequence) 91 | (filter predicate (cdr sequence)))) 92 | (else (filter predicate (cdr sequence))))) 93 | 94 | (filter even? (range 0 50)) 95 | 96 | ;; accu 97 | 98 | (define (accumulate op initial sequence) 99 | (if (null? sequence) 100 | initial 101 | (op (car sequence) 102 | (accumulate op initial (cdr sequence))))) 103 | 104 | (accumulate + 0 (list 1 2 3 4 5)) 105 | 106 | (accumulate cons '() (list 1 2 3 4 5)) 107 | 108 | (define (enumerate-tree tree) 109 | (cond ((null? tree) '()) 110 | ((not (pair? tree)) (list tree)) 111 | (else (append (enumerate-tree (car tree)) 112 | (enumerate-tree (cdr tree)))))) 113 | 114 | (enumerate-tree (list 1 (list 2 (list 3 4)) 5)) 115 | 116 | (define (sum-odd-squares tree) 117 | (accumulate + 118 | 0 119 | (map square 120 | (filter odd? 121 | (enumerate-tree tree))))) 122 | 123 | (define (even-fibs n) 124 | (accumulate cons 125 | nil 126 | (filter even? 127 | (map fib 128 | (enumerate-interval 0 n))))) 129 | 130 | (define (map p sequence) 131 | (accumulate (lambda (x y) (cons (p x) y)) '() sequence)) 132 | 133 | (define (sq n) (* n n)) 134 | (map sq (range 0 5)) 135 | 136 | (define (append seq1 seq2) 137 | (accumulate cons seq2 seq1)) 138 | 139 | (append (list 1 2 3) (list 10 11)) 140 | 141 | (define (length sequence) (accumulate (lambda (x y) (+ y 1)) 0 sequence)) 142 | 143 | (length (range 5 34)) 144 | 145 | -------------------------------------------------------------------------------- /src/test-manager/ordered-map.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-record-type ordered-map 21 | (%make-ordered-map entry-list entry-table) 22 | ordered-map? 23 | (entry-list omap:entry-list set-omap:entry-list!) 24 | (entry-table omap:entry-table set-omap:entry-table!)) 25 | 26 | (define (make-ordered-map) 27 | (%make-ordered-map #f (make-hash-table))) 28 | 29 | (define-record-type omap-entry 30 | (make-omap-entry key item next prev) 31 | omap-entry? 32 | (key omap-entry-key set-omap-entry-key!) 33 | (item omap-entry-item set-omap-entry-item!) 34 | (next omap-entry-next set-omap-entry-next!) 35 | (prev omap-entry-prev set-omap-entry-prev!)) 36 | 37 | (define (omap:fetch-entry omap key) 38 | (hash-table-ref/default (omap:entry-table omap) key #f)) 39 | 40 | (define (omap:put! omap key datum) 41 | (let ((entry (omap:fetch-entry omap key))) 42 | (if entry 43 | (set-omap-entry-item! entry datum) 44 | (omap:put-new-entry! omap key datum)))) 45 | 46 | (define (omap:put-new-entry! omap key datum) 47 | (let* ((head (omap:entry-list omap)) 48 | (new-entry (make-omap-entry key datum head #f))) 49 | (if head (set-omap-entry-prev! head new-entry)) 50 | (set-omap:entry-list! omap new-entry) 51 | (hash-table-set! (omap:entry-table omap) key new-entry))) 52 | 53 | (define (omap:get omap key default) 54 | (let ((entry (omap:fetch-entry omap key))) 55 | (if entry 56 | (omap-entry-item entry) 57 | default))) 58 | 59 | (define (omap:remove! omap key) 60 | (let ((entry (omap:fetch-entry omap key))) 61 | (if entry 62 | (omap:remove-entry! omap key entry)))) 63 | 64 | (define (omap:remove-entry! omap key entry) 65 | (hash-table-delete! (omap:entry-table omap) key) 66 | (let ((old-prev (omap-entry-prev entry)) 67 | (old-next (omap-entry-next entry))) 68 | (if old-prev (set-omap-entry-next! old-prev old-next)) 69 | (if old-next (set-omap-entry-prev! old-next old-prev)))) 70 | 71 | (define (omap:count omap) 72 | (hash-table-size (omap:entry-table omap))) 73 | 74 | (define (omap:clear! omap) 75 | (set-omap:entry-table! omap (make-hash-table)) 76 | (set-omap:entry-list! omap #f)) 77 | 78 | (define (omap:key-list omap) 79 | (reverse 80 | (let loop ((head (omap:entry-list omap))) 81 | (if head 82 | (cons (omap-entry-key head) 83 | (loop (omap-entry-next head))) 84 | '())))) 85 | 86 | (define (omap:for-each omap procedure) 87 | (let loop ((head (omap:entry-list omap))) 88 | (if head 89 | (begin (loop (omap-entry-next head)) 90 | (procedure (omap-entry-key head) (omap-entry-item head)))))) 91 | 92 | -------------------------------------------------------------------------------- /src/test-manager/matching.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; Sigh, different object systems 21 | ;; TODO Document user-extensibility of assert-match 22 | ;; TODO Make assert-match user extensible in guile 23 | (cond-expand 24 | (guile 25 | (define (generic-match pattern object) 26 | (cond ((and (string? pattern) 27 | (string? object)) 28 | (re-string-search-forward pattern object)) 29 | (else 30 | (equal? pattern object))))) 31 | (else 32 | (define-generic generic-match (pattern object)) 33 | 34 | (define-method generic-match (pattern object) 35 | (equal? pattern object)) 36 | 37 | (define-method generic-match ((pattern ) (object )) 38 | (re-string-search-forward pattern object)) 39 | 40 | (define-method generic-match ((pattern ) (object )) 41 | (reduce boolean/and #t (map generic-match 42 | (vector->list pattern) 43 | (vector->list object)))) 44 | 45 | (define-method generic-match ((pattern ) (object )) 46 | (and (generic-match (car pattern) (car object)) 47 | (generic-match (cdr pattern) (cdr object)))) 48 | 49 | (define-method generic-match ((pattern ) (object )) 50 | (or (= pattern object) 51 | (= pattern (->significant-figures 5 object)))))) 52 | 53 | (define (->significant-figures places number) 54 | (define (round-down? digit-trail) 55 | (or (null? digit-trail) 56 | (memq (car digit-trail) '(#\0 #\1 #\2 #\3 #\4)) 57 | (and (eq? (car digit-trail) #\.) 58 | (or (null? (cdr digit-trail)) 59 | (memq (cadr digit-trail) '(#\0 #\1 #\2 #\3 #\4)))))) 60 | (define (decimal-increment reversed-digit-list) 61 | (cond ((null? reversed-digit-list) 62 | '(#\1)) 63 | ((eq? (car reversed-digit-list) #\.) 64 | (cons (car reversed-digit-list) 65 | (decimal-increment (cdr reversed-digit-list)))) 66 | ((eq? (car reversed-digit-list) #\9) 67 | (cons #\0 (decimal-increment (cdr reversed-digit-list)))) 68 | (else 69 | (cons (integer->char (+ 1 (char->integer (car reversed-digit-list)))) 70 | (cdr reversed-digit-list))))) 71 | (let ((digits (string->list (number->string number)))) 72 | (let loop ((result '()) 73 | (more-digits digits) 74 | (places places) 75 | (zeros-matter? #f)) 76 | (cond ((null? more-digits) 77 | (string->number (list->string (reverse result)))) 78 | ;; TODO This relies on being after the decimal point 79 | ((= places 0) 80 | (string->number 81 | (list->string 82 | (reverse 83 | (if (round-down? more-digits) 84 | result 85 | (decimal-increment result)))))) 86 | ((eq? #\. (car more-digits)) 87 | (loop (cons (car more-digits) result) 88 | (cdr more-digits) 89 | places 90 | zeros-matter?)) 91 | ((eq? #\0 (car more-digits)) 92 | (loop (cons (car more-digits) result) 93 | (cdr more-digits) 94 | (if zeros-matter? (- places 1) places) 95 | zeros-matter?)) 96 | (else 97 | (loop (cons (car more-digits) result) 98 | (cdr more-digits) 99 | (- places 1) 100 | #t)))))) 101 | -------------------------------------------------------------------------------- /src/test-manager/testing.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;;; Test Registration 21 | 22 | (define (register-test test) 23 | (tg:register-test! *current-test-group* test)) 24 | 25 | (define *anonymous-test-count* 0) 26 | 27 | (define (generate-test-name) 28 | (set! *anonymous-test-count* (+ *anonymous-test-count* 1)) 29 | (string->symbol 30 | (string-append "anonymous-test-" (number->string *anonymous-test-count*)))) 31 | 32 | (define (detect-docstring structure) 33 | (if (string? structure) 34 | structure 35 | #f)) 36 | 37 | ;; TODO Teach Emacs to syntax-highlight this just like define 38 | (define-syntax define-test 39 | (syntax-rules () 40 | ((define-test (name formal ...) body-exp1 body-exp2 ...) 41 | (let ((proc (lambda (formal ...) body-exp1 body-exp2 ...))) 42 | (register-test 43 | (make-single-test 'name proc (detect-docstring (quote body-exp1)))))) 44 | ((define-test () body-exp1 body-exp2 ...) 45 | (let ((proc (lambda () body-exp1 body-exp2 ...))) 46 | (register-test 47 | (make-single-test (generate-test-name) proc (detect-docstring (quote body-exp1)))))) 48 | ((define-test form) 49 | (let ((proc (lambda () form))) 50 | (register-test 51 | (make-single-test (generate-test-name) proc (quote form))))))) 52 | 53 | (define-syntax define-each-test 54 | (syntax-rules () 55 | ((define-each-test form ...) 56 | (begin (define-test form) ...)))) 57 | 58 | (define-syntax define-each-check 59 | (syntax-rules () 60 | ((define-each-check form ...) 61 | (begin (define-test () (check form)) ...)))) 62 | 63 | ;;;; Test Running 64 | 65 | ;; Poor man's dynamic dispatch by storing the 66 | ;; procedures that do the job in a record 67 | (define (run-given-test test-runner test) 68 | ((tr:run-one test-runner) (list (st:name test)) test)) 69 | 70 | (define (run-given-group test-runner group name-stack) 71 | ((tr:run-group test-runner) group name-stack)) 72 | 73 | (define (run-given-test-or-group test-runner test name-stack) 74 | (cond ((test-group? test) 75 | (run-given-group test-runner test name-stack)) 76 | ((single-test? test) 77 | (run-given-test test-runner test)) 78 | (else 79 | (error "Unknown test type" test)))) 80 | 81 | (define (report-results test-runner) 82 | ((tr:report-results test-runner))) 83 | 84 | ;; Allows access to old test results if needed and keeps failure 85 | ;; continuations from getting garbage collected. 86 | (define *last-test-runner* #f) 87 | 88 | (define (run-test test-name-stack . opt-test-runner) 89 | (let-optional opt-test-runner ((test-runner (make-standard-test-runner))) 90 | (let loop ((test (current-test-group)) 91 | (stack-left test-name-stack) 92 | (stack-traversed '())) 93 | (cond ((null? stack-left) 94 | (run-given-test-or-group test-runner test (reverse stack-traversed))) 95 | ((test-group? test) 96 | (tg:in-group-context test 97 | (lambda () 98 | (tg:in-test-context test 99 | (lambda () 100 | (loop (tg:get test (car stack-left)) 101 | (cdr stack-left) 102 | (cons (car stack-left) stack-traversed))))))) 103 | (else 104 | (error "Name stack did not lead to a valid test" test-name-stack)))) 105 | (set! *last-test-runner* test-runner) 106 | (report-results test-runner))) 107 | 108 | (define (run-registered-tests . opt-test-runner) 109 | (apply run-test (cons '() opt-test-runner))) 110 | 111 | (define (clear-registered-tests!) 112 | (tg:clear! (current-test-group))) 113 | -------------------------------------------------------------------------------- /src/test-manager/portability.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; Macros 21 | (cond-expand 22 | (guile 23 | (use-modules (ice-9 syncase))) 24 | (else)) 25 | 26 | ;; SRFI-9: define-record-type 27 | (cond-expand 28 | (guile 29 | (use-modules (srfi srfi-9))) 30 | (srfi-9)) 31 | 32 | ;; Structured conditions 33 | (cond-expand 34 | (guile 35 | (load-relative "guile-conditions")) 36 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 37 | (load-relative "mitscheme-conditions"))) 38 | 39 | ;; SRFI-69: Hash tables 40 | (cond-expand 41 | (srfi-69) 42 | (else ; Do I want to use Guile's hash tables instead? 43 | (load-relative "srfi-69-hash-tables"))) 44 | 45 | ;; Optional arguments 46 | (cond-expand 47 | (guile 48 | (use-modules (ice-9 optargs))) 49 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 50 | (define-syntax let-optional 51 | (syntax-rules () 52 | ((_ arg-list () expr ...) 53 | (begin expr ...)) 54 | ((_ arg-list ((variable1 default1) binding ...) expr ...) 55 | (if (null? arg-list) 56 | (let ((variable1 default1) binding ...) 57 | expr ...) 58 | (let ((variable1 (car arg-list)) 59 | (arg-list (cdr arg-list))) 60 | (let-optional 61 | arg-list 62 | (binding ...) 63 | expr ...)))) 64 | ((_ arg-list (variable1 binding ...) expr ...) 65 | (let ((variable1 (car arg-list)) 66 | (arg-list (cdr arg-list))) 67 | (let-optional 68 | arg-list 69 | (binding ...) 70 | expr ...))) 71 | )) 72 | )) 73 | 74 | ;; Fluid-let (in the MIT Scheme sense of the word 'fluid'. 75 | (cond-expand 76 | (guile 77 | (define-syntax fluid-let 78 | (syntax-rules () 79 | ((_ () expr ...) 80 | (begin expr ...)) 81 | ((_ ((variable1 value1) binding ...) expr ...) 82 | (let ((out-value variable1) 83 | (in-value value1)) 84 | (dynamic-wind 85 | (lambda () 86 | (set! out-value variable1) 87 | (set! variable1 in-value)) 88 | (lambda () 89 | (fluid-let (binding ...) 90 | expr ...)) 91 | (lambda () 92 | (set! in-value variable1) 93 | (set! variable1 out-value)))))))) 94 | (else)) 95 | 96 | ;; Regexes (using MIT Scheme's name for no good reason) 97 | (cond-expand 98 | (guile 99 | (use-modules (ice-9 regex)) 100 | (define re-string-search-forward string-match)) 101 | (else 102 | (load-option 'regular-expression))) 103 | 104 | (cond-expand 105 | (guile 106 | (define (string-search-forward pattern string) 107 | (string-contains string pattern))) 108 | (else 109 | 'ok)) 110 | 111 | ;; Pretty printing 112 | (cond-expand 113 | (guile 114 | ;; TODO Does Guile have pretty printing? 115 | (define (pp thing) (display thing) (newline))) 116 | (else)) 117 | 118 | ;; Object system 119 | (cond-expand 120 | (guile 121 | 'ok) 122 | (else 123 | (load-option 'sos))) 124 | 125 | ;; Symbols 126 | (cond-expand 127 | (guile 128 | (define (generate-uninterned-symbol) 129 | (make-symbol "symbol")) 130 | (define (make-synthetic-identifier prefix) 131 | (make-symbol (symbol->string prefix)))) 132 | (else 133 | 'ok)) 134 | 135 | ;; Hackery to make syntactic-closures macro code work (with less 136 | ;; hygiene!) in Guile's defmacro system. 137 | (cond-expand 138 | (guile 139 | (define (close-syntax form env) 140 | form)) 141 | (else 142 | 'ok)) 143 | 144 | ;; Faking out the repl history. (produces foo) will not work at the 145 | ;; Guile repl. 146 | (cond-expand 147 | (guile 148 | (define (out) 149 | #f)) 150 | (else 151 | 'ok)) 152 | -------------------------------------------------------------------------------- /src/test-manager/test-runner.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-record-type 21 | (make-test-runner x y z) 22 | test-runner? 23 | (x tr:run-one) 24 | (y tr:run-group) 25 | (z tr:report-results)) 26 | 27 | ;; TODO This currying is kind of nasty, but preferable to a single global 28 | ;; *test-result-map*. Is there a way to get around this nastiness and 29 | ;; preserve a reasonable api for these functions? 30 | (define ((standard-run-one-test result-map) test-name-stack test) 31 | (let ((test-result (capture-unhandled-errors (st:thunk test)))) 32 | (cond 33 | ((and (condition? test-result) 34 | (condition/test-failure? test-result)) 35 | (omap:put! result-map test-name-stack test-result) 36 | (display "F")) 37 | ((and (condition? test-result) 38 | (condition/error? test-result)) 39 | (omap:put! result-map test-name-stack test-result) 40 | (display "E")) 41 | (else (omap:put! result-map test-name-stack 'pass) 42 | (display "."))))) 43 | 44 | (define ((standard-run-test-group result-map) group name-stack) 45 | (define (run-test-in-context name test) 46 | (tg:in-test-context group 47 | (lambda () 48 | (if (single-test? test) 49 | ((standard-run-one-test result-map) 50 | (cons name name-stack) test) 51 | ((standard-run-test-group result-map) 52 | test (cons name name-stack)))))) 53 | (tg:in-group-context group 54 | (lambda () 55 | (omap:for-each 56 | (tg:test-map group) 57 | run-test-in-context)))) 58 | 59 | (define ((standard-report-results result-map)) 60 | (newline) ; Finish the run-one-test wallpaper 61 | (let ((passes 0) 62 | (failures 0) 63 | (errors 0)) 64 | (define (report-misbehavior kind test-name-stack condition) 65 | (display " ") 66 | (display (+ failures errors)) 67 | (display ") ") 68 | (display kind) 69 | (display " (") 70 | (display (condition/continuation condition)) 71 | (display "): ") 72 | (newline) 73 | (display (reverse test-name-stack)) 74 | (display ": ") 75 | (newline) 76 | ;; TODO Oh, what a mess! 77 | (let ((test (tg:get (current-test-group) (reverse test-name-stack)))) 78 | (if test 79 | (let ((docstring (st:docstring test))) 80 | (if docstring 81 | (if (string? docstring) 82 | (begin (display docstring) (newline)) 83 | (pp docstring)))))) 84 | (write-condition-report condition (current-output-port)) 85 | (newline) 86 | (newline)) 87 | (newline) 88 | (omap:for-each 89 | result-map 90 | (lambda (test-name-stack result) 91 | (cond 92 | ((and (condition? result) 93 | (condition/test-failure? result)) 94 | (set! failures (+ failures 1)) 95 | (report-misbehavior "Failure" test-name-stack result)) 96 | ((and (condition? result) 97 | (condition/error? result)) 98 | (set! errors (+ errors 1)) 99 | (report-misbehavior "Error" test-name-stack result)) 100 | ((eq? 'never-ran result)) ; Skip tests that haven't run 101 | (else 102 | (set! passes (+ passes 1)))))) 103 | 104 | (display (+ passes failures errors)) 105 | (display " tests, ") 106 | (display failures) 107 | (display " failures, ") 108 | (display errors) 109 | (display " errors.") 110 | (newline) 111 | (+ failures errors))) 112 | 113 | (define (make-standard-test-runner) 114 | (let ((result-map (make-ordered-map))) 115 | (make-test-runner (standard-run-one-test result-map) 116 | (standard-run-test-group result-map) 117 | (standard-report-results result-map)))) 118 | -------------------------------------------------------------------------------- /src/test-manager/assertions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define (ensure-forced object) 21 | (if (promise? object) 22 | (force object) 23 | object)) 24 | 25 | (define (instantiate-template template arguments) 26 | (if (not (= (length arguments) (- (length template) 1))) 27 | (error "Template and argument lists are length-mismatched: " 28 | template arguments)) 29 | (let loop ((result (car template)) 30 | (template (cdr template)) 31 | (arguments arguments)) 32 | (if (null? template) 33 | result 34 | (loop (string-append result (car arguments) (car template)) 35 | (cdr template) 36 | (cdr arguments))))) 37 | 38 | (define (messagify object) 39 | (with-output-to-string (lambda () (display object)))) 40 | 41 | (define (build-message header template . arguments) 42 | (delay 43 | (let ((body (instantiate-template template (map messagify arguments)))) 44 | (if header 45 | (string-append (messagify (ensure-forced header)) "\n" body) 46 | (string-append "\n" body))))) 47 | 48 | (define (assert-proc message proc) 49 | (if (proc) 50 | 'ok 51 | (test-fail (messagify (ensure-forced message))))) 52 | 53 | (define (assert-equivalent predicate . opt-pred-name) 54 | (define (full-message message expected actual) 55 | (if (null? opt-pred-name) 56 | (build-message message 57 | '("<" "> expected but was\n<" ">.") 58 | expected actual) 59 | (build-message message 60 | '("<" "> expected to be " " to\n<" 61 | ">.") 62 | expected (car opt-pred-name) actual))) 63 | (lambda (expected actual . opt-message) 64 | (let-optional 65 | opt-message ((message #f)) 66 | (assert-proc (full-message message expected actual) 67 | (lambda () (predicate expected actual)))))) 68 | 69 | (define assert-eq (assert-equivalent eq? "eq?")) 70 | (define assert-eqv (assert-equivalent eqv? "eqv?")) 71 | (define assert-equal (assert-equivalent equal? "equal?")) 72 | (define assert-= (assert-equivalent = "=")) 73 | (define assert-equals assert-equal) 74 | (define assert= assert-=) 75 | (define assert-< (assert-equivalent < "<")) 76 | (define assert-> (assert-equivalent > ">")) 77 | (define assert-<= (assert-equivalent <= "<=")) 78 | (define assert->= (assert-equivalent >= ">=")) 79 | 80 | (define (assert-in-delta expected actual delta . opt-message) 81 | (let-optional opt-message ((message #f)) 82 | (let ((full-message 83 | (build-message message '("<" "> and\n<" "> expected to be within\n<" 84 | "> of each other.") 85 | expected actual delta))) 86 | (assert-proc full-message (lambda () (<= (abs (- expected actual)) delta)))))) 87 | 88 | (define (assert-matches regexp string . opt-message) 89 | (let-optional opt-message ((message #f)) 90 | (let ((full-message 91 | (build-message message '("<" "> expected to match <" ">") 92 | string regexp))) 93 | (assert-proc full-message 94 | (lambda () 95 | (generic-match regexp string)))))) 96 | 97 | ;; TODO how repetitive! 98 | (define (assert-no-match regexp string . opt-message) 99 | (let-optional opt-message ((message #f)) 100 | (let ((full-message 101 | (build-message message '("<" "> expected not to match <" ">") 102 | string regexp))) 103 | (assert-proc full-message 104 | (lambda () 105 | (not (generic-match regexp string))))))) 106 | 107 | (define (assert-true thing . opt-message) 108 | (let-optional opt-message ((message #f)) 109 | (let ((full-message 110 | (build-message message '("<" "> expected to be a true value.") 111 | thing))) 112 | (assert-proc full-message (lambda () thing))))) 113 | 114 | (define (assert-false thing . opt-message) 115 | (let-optional opt-message ((message #f)) 116 | (let ((full-message 117 | (build-message message '("<" "> expected to be a false value.") 118 | thing))) 119 | (assert-proc full-message (lambda () (not thing)))))) 120 | -------------------------------------------------------------------------------- /src/nine.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; nine.scm 3 | ;; 4 | 5 | ;; import 6 | ;; 7 | (load "lil_00.scm") 8 | 9 | ;; vars for testing 10 | ;; 11 | 12 | (define x0 (list 1 2 3)) 13 | (define x1 (list 1 2 3 (list 4 5 6))) 14 | (define x2 (list 15 (list 3 (list 3 2 1) 9) 12 (list 4 3))) 15 | (define y0 (list 'a 'a 'a 'a 'b 'c 'c 'a 'a 'd 'e 'e 'e 'e)) 16 | (define z0 (list 'a 'b 'c 'c 'd)) 17 | (define z1 (list 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k)) 18 | 19 | ;; p07 - flatten 20 | ;; 21 | (define (flatten xs) 22 | (cond ((null? xs) '()) 23 | ((atom? (car xs)) (cons (car xs) (flatten (cdr xs)))) 24 | (else (append (flatten (car xs)) (flatten (cdr xs)))))) 25 | 26 | x0 (flatten x0) 27 | x1 (flatten x1) 28 | x2 (flatten x2) 29 | 30 | ;; p08 - compress 31 | ;; 32 | (define (compress xs) 33 | (fold-right (lambda (y ys) 34 | (cond ((null? ys) (cons y ys)) 35 | ((eq? y (car ys)) ys) 36 | (else (cons y ys)))) 37 | '() xs)) 38 | 39 | y0 (compress y0) 40 | 41 | ;; (fold-right kons knil lis) = (kons (car lis) (fold-right kons knil (cdr lis))) 42 | 43 | ;; p09 - pack 44 | ;; 45 | (define (pack xs) 46 | (define (red y ys) 47 | (if (and (not (null? ys)) (eq? y (caar ys))) 48 | (cons (cons y (car ys)) (cdr ys)) 49 | (cons (list y) ys))) 50 | (fold-right red '() xs)) 51 | 52 | y0 (pack y0) 53 | 54 | ;; p10 - encode 55 | ;; 56 | (define (encode xs) 57 | (map (lambda (e) 58 | (cons (length e) (car e))) 59 | (pack xs))) 60 | 61 | y0 (encodeUsingPack y0) 62 | 63 | ;; p11 - encodeModified 64 | ;; 65 | (define (encodeModified xs) 66 | (map (lambda (e) 67 | (if (= 1 (car e)) 68 | (cdr e) 69 | e)) 70 | (encode xs))) 71 | 72 | y0 (encodeModified y0) 73 | 74 | ;; p12 - decode 75 | ;; 76 | (define (decode xs) 77 | (flatten (map expand xs))) 78 | 79 | (define (expand tup) 80 | (if (= (car tup) 0) 81 | '() 82 | (cons (cdr tup) (expand (cons (- (car tup) 1) (cdr tup)))))) 83 | 84 | (expand (cons 4 'a)) 85 | 86 | (encode y0) (decode (encode y0)) 87 | 88 | ;; p13 - encodeDirect 89 | ;; 90 | (define (encodeDirect xs) 91 | (define (red y ys) 92 | (if (and (not (null? ys)) (eq? y (caar ys))) 93 | (cons (cons y (+ 1 (cdar ys))) (cdr ys)) 94 | (cons (cons y 1) ys))) 95 | (fold-right red '() xs)) 96 | 97 | y0 (encodeDirect y0) 98 | 99 | ;; p14 - duplicate 100 | ;; 101 | (define (duplicate xs) 102 | (flatten (map (lambda (a b) 103 | (list a b)) xs xs))) 104 | 105 | z0 (duplicate z0) 106 | 107 | ;; p15 - duplicateN 108 | ;; 109 | (define (duplicateN n xs) 110 | (flatten (map (lambda (e) (expand (cons n e))) xs))) 111 | 112 | z0 (duplicateN 4 z0) 113 | 114 | ;; p16 - drop 115 | ;; 116 | (define (drop n xs) 117 | (define (loop cnt rem) 118 | (cond ((null? rem) '()) 119 | ((zero? (modulo cnt n)) (loop (1+ cnt) (cdr rem))) 120 | (else (cons (car rem) (loop (1+ cnt) (cdr rem)))))) 121 | (loop 1 xs)) 122 | 123 | z1 (drop 3 z1) 124 | 125 | ;; p17 - split 126 | ;; 127 | (define (split n xs) 128 | (define (loop accu rem cnt) 129 | (cond ((zero? cnt) (cons (reverse accu) (cdr rem))) 130 | (else (loop (cons (car rem) accu) (cdr rem) (-1+ cnt))))) 131 | (loop '() xs n)) 132 | 133 | z1 (split 4 z1) 134 | 135 | ;; p18 - slice 136 | ;; 137 | (define (sliceA i k xs) 138 | (define (loop accu rem cnt) 139 | (cond ((= cnt k) (reverse accu)) 140 | ((and (>= cnt i) (< cnt k)) 141 | (loop (cons (car rem) accu) (cdr rem) (+ cnt 1))) 142 | (else (loop accu (cdr rem) (+ cnt 1))))) 143 | (loop '() xs 0)) 144 | 145 | (define (sliceB i k xs) 146 | (cond ((null? xs) '()) 147 | ((< k 1) '()) 148 | ((> i 0) (sliceB (- i 1) (- k 1) (cdr xs))) 149 | (else (cons (car xs) (sliceB i (- k 1) (cdr xs)))))) 150 | 151 | z1 (sliceB 3 7 z1) 152 | 153 | ;; p19 - rotate 154 | ;; 155 | (define (rotate n xs) 156 | (define (loop accu rem cnt) 157 | (if (zero? cnt) (append rem (reverse accu)) 158 | (loop (cons (car rem) accu) (cdr rem) (- cnt 1)))) 159 | (loop '() xs n)) 160 | 161 | (define (rotateB n xs) 162 | (if (zero? n) xs 163 | (rotateB (- n 1) (append (cdr xs) (list (car xs)))))) 164 | 165 | z1 (rotateB 3 z1) 166 | 167 | ;; p20 - removeAt 168 | ;; 169 | (define (removeAtOnly n xs) 170 | (if (zero? n) (car xs) 171 | (removeAt (- n 1) (cdr xs)))) 172 | 173 | (define (removeAt n xs) 174 | (define (loop accu rem n) 175 | (if (zero? n) (cons (car rem) (append (reverse accu) (cdr rem))) 176 | (loop (cons (car rem) accu) (cdr rem) (- n 1)))) 177 | (loop '() xs n)) 178 | 179 | z1 (removeAt 4 z1) 180 | 181 | ;; p21 - insertAt 182 | ;; 183 | (define (insertAt s n xs) 184 | (cond ((null? xs) '()) 185 | ((= n 0) (cons s xs)) 186 | (else (cons (car xs) (insertAt s (- n 1) (cdr xs)))))) 187 | 188 | z1 (insertAt 'new 1 z1) 189 | 190 | ;; p22 - range 191 | ;; 192 | (define (range a b) 193 | (if (= a b) '() 194 | (cons a (range (+ a 1) b)))) 195 | 196 | (range 4 14) 197 | 198 | ;; p23 - randomSelect 199 | ;; 200 | (define (randomSelect n xs) 201 | (let ((plucked (removeAt (random (length xs)) xs))) 202 | (if (= n 0) '() 203 | (cons (car plucked) (randomSelect (- n 1) (cdr plucked)))))) 204 | 205 | z1 (randomSelect 3 z1) 206 | 207 | ;; p24 - lotto 208 | ;; 209 | (define (lotto num-picks max) 210 | (randomSelect num-picks (range 0 max))) 211 | 212 | (lotto 6 49) 213 | 214 | ;; p25 - randomPermute 215 | ;; 216 | (define (randomPermute xs) 217 | (if (null? xs) '() 218 | (let ((plucked (removeAt (random (length xs)) xs))) 219 | (cons (car plucked) (randomPermute (cdr plucked)))))) 220 | 221 | z1 (randomPermute z1) 222 | 223 | ;; p26 - combinations 224 | ;; 225 | (define (combinationsA n xs) 226 | (map (lambda (x) 227 | (map (lambda (y) 228 | (map (lambda (z) 229 | (list x y z)) xs)) 230 | xs)) 231 | xs)) 232 | 233 | (define (combinations n xs) 234 | (define (addCombo))) 235 | (combinations 3 '(a b c d e f)) 236 | 237 | ;; monads 238 | ;; 239 | (define (return v) 240 | (lambda (s) (cons v s))) 241 | 242 | (define (bind mv f) 243 | (lambda (s) 244 | (let ((p (mv s))) 245 | ((f (car p)) (cdr p))))) 246 | 247 | (define (take-sugar mv) 248 | (bind mv (lambda (v) 249 | (lambda (s) (cons v (- s 1)))))) 250 | 251 | ((take-sugar (take-sugar (return "me"))) 10) 252 | 253 | 254 | 255 | -------------------------------------------------------------------------------- /src/test-manager/test-group.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-record-type single-test 21 | (make-single-test name thunk docstring) 22 | single-test? 23 | (name st:name) 24 | (thunk st:thunk) 25 | (docstring st:docstring)) 26 | 27 | (define-record-type test-group 28 | (%make-test-group 29 | name 30 | group-surround group-set-up group-tear-down 31 | surround set-up tear-down 32 | test-map) 33 | test-group? 34 | (name tg:name) 35 | (group-surround tg:group-surround set-tg:group-surround!) 36 | (group-set-up tg:group-set-up set-tg:group-set-up!) 37 | (group-tear-down tg:group-tear-down set-tg:group-tear-down!) 38 | (surround tg:surround set-tg:surround!) 39 | (set-up tg:set-up set-tg:set-up!) 40 | (tear-down tg:tear-down set-tg:tear-down!) 41 | (test-map tg:test-map)) 42 | 43 | (define (make-test-group name) 44 | (%make-test-group 45 | name 46 | (lambda (run-test) (run-test)) 47 | (lambda () 'done) 48 | (lambda () 'done) 49 | (lambda (run-test) (run-test)) 50 | (lambda () 'done) 51 | (lambda () 'done) 52 | (make-ordered-map))) 53 | 54 | (define (tg:size group) 55 | (omap:count (tg:test-map group))) 56 | 57 | (define (tg:register-test! group test) 58 | (omap:put! (tg:test-map group) (st:name test) test)) 59 | 60 | (define (tg:clear! group) 61 | (omap:clear! (tg:test-map group))) 62 | 63 | (define (tg:find-or-make-subgroup group name) 64 | (let ((subgroup (omap:get (tg:test-map group) name #f))) 65 | (cond ((not subgroup) 66 | (tg:make-subgroup! group name)) 67 | ((procedure? subgroup) 68 | (error "Namespace collision between tests and subgroups" group name)) 69 | (else subgroup)))) 70 | 71 | (define (tg:make-subgroup! group name) 72 | (let ((new-group (make-test-group name))) 73 | (omap:put! (tg:test-map group) name new-group) 74 | new-group)) 75 | 76 | (define (tg:get group name) 77 | (cond ((null? name) group) 78 | ((pair? name) 79 | (tg:get (tg:get group (car name)) (cdr name))) 80 | (else 81 | (omap:get (tg:test-map group) name #f)))) 82 | 83 | (define (tg:in-group-context group thunk) 84 | "Runs the given thunk in the whole-group context of the given test 85 | group (see also tg:in-test-context)." 86 | ((tg:group-surround group) 87 | (lambda () 88 | (dynamic-wind 89 | (tg:group-set-up group) 90 | thunk 91 | (tg:group-tear-down group))))) 92 | 93 | (define (tg:in-test-context group thunk) 94 | "Runs the given thunk in the single-test context of the given test 95 | group. Does not create the whole-group context provided by 96 | tg:in-group-context." 97 | ((tg:surround group) 98 | (lambda () 99 | (dynamic-wind 100 | (tg:set-up group) 101 | thunk 102 | (tg:tear-down group))))) 103 | 104 | (define *current-test-group* (make-test-group 'top-level)) 105 | 106 | (define (current-test-group) *current-test-group*) 107 | 108 | (define (with-top-level-group group thunk) 109 | (fluid-let ((*current-test-group* group)) 110 | (thunk))) 111 | 112 | (define-syntax in-test-group 113 | (syntax-rules () 114 | ((_ name body-exp ...) 115 | (let ((group (tg:find-or-make-subgroup *current-test-group* 'name))) 116 | (fluid-let ((*current-test-group* group)) 117 | body-exp ...) 118 | group)))) 119 | 120 | (define (*define-group-surround proc) 121 | (set-tg:group-surround! (current-test-group) proc)) 122 | 123 | (define (*define-group-set-up thunk) 124 | (set-tg:group-set-up! (current-test-group) thunk)) 125 | 126 | (define (*define-group-tear-down thunk) 127 | (set-tg:group-tear-down! (current-test-group) thunk)) 128 | 129 | (define (*define-surround proc) 130 | (set-tg:surround! (current-test-group) proc)) 131 | 132 | (define (*define-set-up thunk) 133 | (set-tg:set-up! (current-test-group) thunk)) 134 | 135 | (define (*define-tear-down thunk) 136 | (set-tg:tear-down! (current-test-group) thunk)) 137 | 138 | ;;; Portable slightly non-hygienic macros suck... 139 | (cond-expand 140 | (guile ;; TODO less hygienic than it should be... 141 | (define-macro (define-group-surround . body) 142 | `(*define-group-surround 143 | (lambda (run-test) 144 | ,@body)))) 145 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 146 | (define-syntax define-group-surround 147 | (er-macro-transformer 148 | (lambda (form rename compare) 149 | (let ((body (cdr form))) 150 | `(,(rename '*define-group-surround) 151 | (,(rename 'lambda) (run-test) 152 | ,@body)))))))) 153 | 154 | (define-syntax define-group-set-up 155 | (syntax-rules () 156 | ((_ body-exp ...) 157 | (*define-group-set-up 158 | (lambda () 159 | body-exp ...))))) 160 | 161 | (define-syntax define-group-tear-down 162 | (syntax-rules () 163 | ((_ body-exp ...) 164 | (*define-group-tear-down 165 | (lambda () 166 | body-exp ...))))) 167 | 168 | ;;; Portable slightly non-hygienic macros suck... 169 | (cond-expand 170 | (guile ;; TODO less hygienic than it should be... 171 | (define-macro (define-surround . body) 172 | `(*define-surround 173 | (lambda (run-test) 174 | ,@body)))) 175 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 176 | (define-syntax define-surround 177 | (er-macro-transformer 178 | (lambda (form rename compare) 179 | (let ((body (cdr form))) 180 | `(,(rename '*define-surround) 181 | (,(rename 'lambda) (run-test) 182 | ,@body)))))))) 183 | 184 | (define-syntax define-set-up 185 | (syntax-rules () 186 | ((_ body-exp ...) 187 | (*define-set-up 188 | (lambda () 189 | body-exp ...))))) 190 | 191 | (define-syntax define-tear-down 192 | (syntax-rules () 193 | ((_ body-exp ...) 194 | (*define-tear-down 195 | (lambda () 196 | body-exp ...))))) 197 | -------------------------------------------------------------------------------- /src/kanren-book/mk.scm: -------------------------------------------------------------------------------- 1 | ;;; Code that accompanies ``The Reasoned Schemer'' 2 | ;;; Daniel P. Friedman, William E. Byrd and Oleg Kiselyov 3 | ;;; MIT Press, Cambridge, MA, 2005 4 | ;;; 5 | ;;; The implementation of the logic system used in the book 6 | 7 | ;;; This file was generated by writeminikanren.pl 8 | ;;; Generated at 2005-08-12 11:27:16 9 | 10 | (define-syntax lambdag@ 11 | (syntax-rules () 12 | ((_ (s) e) (lambda (s) e)))) 13 | 14 | (define-syntax lambdaf@ 15 | (syntax-rules () 16 | ((_ () e) (lambda () e)))) 17 | 18 | (define rhs cdr) 19 | (define lhs car) 20 | (define size-s length) 21 | (define var vector) 22 | (define var? vector?) 23 | 24 | (define empty-s '()) 25 | 26 | (define walk 27 | (lambda (v s) 28 | (cond 29 | ((var? v) 30 | (cond 31 | ((assq v s) => 32 | (lambda (a) 33 | (walk (rhs a) s))) 34 | (else v))) 35 | (else v)))) 36 | 37 | (define ext-s 38 | (lambda (x v s) 39 | (cons `(,x . ,v) s))) 40 | 41 | (define unify 42 | (lambda (v w s) 43 | (let ((v (walk v s)) 44 | (w (walk w s))) 45 | (cond 46 | ((eq? v w) s) 47 | ((var? v) (ext-s v w s)) 48 | ((var? w) (ext-s w v s)) 49 | ((and (pair? v) (pair? w)) 50 | (cond 51 | ((unify (car v) (car w) s) => 52 | (lambda (s) 53 | (unify (cdr v) (cdr w) s))) 54 | (else #f))) 55 | ((equal? v w) s) 56 | (else #f))))) 57 | 58 | (define ext-s-check 59 | (lambda (x v s) 60 | (cond 61 | ((occurs-check x v s) #f) 62 | (else (ext-s x v s))))) 63 | 64 | (define occurs-check 65 | (lambda (x v s) 66 | (let ((v (walk v s))) 67 | (cond 68 | ((var? v) (eq? v x)) 69 | ((pair? v) 70 | (or 71 | (occurs-check x (car v) s) 72 | (occurs-check x (cdr v) s))) 73 | (else #f))))) 74 | 75 | (define unify-check 76 | (lambda (v w s) 77 | (let ((v (walk v s)) 78 | (w (walk w s))) 79 | (cond 80 | ((eq? v w) s) 81 | ((var? v) (ext-s-check v w s)) 82 | ((var? w) (ext-s-check w v s)) 83 | ((and (pair? v) (pair? w)) 84 | (cond 85 | ((unify-check (car v) (car w) s) => 86 | (lambda (s) 87 | (unify-check (cdr v) (cdr w) s))) 88 | (else #f))) 89 | ((equal? v w) s) 90 | (else #f))))) 91 | 92 | (define walk* 93 | (lambda (v s) 94 | (let ((v (walk v s))) 95 | (cond 96 | ((var? v) v) 97 | ((pair? v) 98 | (cons 99 | (walk* (car v) s) 100 | (walk* (cdr v) s))) 101 | (else v))))) 102 | 103 | (define reify-s 104 | (lambda (v s) 105 | (let ((v (walk v s))) 106 | (cond 107 | ((var? v) (ext-s v (reify-name (size-s s)) s)) 108 | ((pair? v) (reify-s (cdr v) (reify-s (car v) s))) 109 | (else s))))) 110 | 111 | (define reify-name 112 | (lambda (n) 113 | (string->symbol 114 | (string-append "_" "." (number->string n))))) 115 | 116 | (define reify 117 | (lambda (v) 118 | (walk* v (reify-s v empty-s)))) 119 | 120 | (define-syntax run 121 | (syntax-rules () 122 | ((_ n^ (x) g ...) 123 | (let ((n n^) (x (var 'x))) 124 | (if (or (not n) (> n 0)) 125 | (map-inf n 126 | (lambda (s) 127 | (reify (walk* x s))) 128 | ((all g ...) empty-s)) 129 | '()))))) 130 | 131 | (define-syntax case-inf 132 | (syntax-rules () 133 | ((_ e on-zero ((a^) on-one) ((a f) on-choice)) 134 | (let ((a-inf e)) 135 | (cond 136 | ((not a-inf) on-zero) 137 | ((not (and 138 | (pair? a-inf) 139 | (procedure? (cdr a-inf)))) 140 | (let ((a^ a-inf)) 141 | on-one)) 142 | (else (let ((a (car a-inf)) 143 | (f (cdr a-inf))) 144 | on-choice))))))) 145 | 146 | (define-syntax mzero 147 | (syntax-rules () 148 | ((_) #f))) 149 | 150 | (define-syntax unit 151 | (syntax-rules () 152 | ((_ a) a))) 153 | 154 | (define-syntax choice 155 | (syntax-rules () 156 | ((_ a f) (cons a f)))) 157 | 158 | (define map-inf 159 | (lambda (n p a-inf) 160 | (case-inf a-inf 161 | '() 162 | ((a) 163 | (cons (p a) '())) 164 | ((a f) 165 | (cons (p a) 166 | (cond 167 | ((not n) (map-inf n p (f))) 168 | ((> n 1) (map-inf (- n 1) p (f))) 169 | (else '()))))))) 170 | 171 | (define succeed (lambdag@ (s) (unit s))) 172 | (define fail (lambdag@ (s) (mzero))) 173 | 174 | (define == 175 | (lambda (v w) 176 | (lambdag@ (s) 177 | (cond 178 | ((unify v w s) => succeed) 179 | (else (fail s)))))) 180 | 181 | (define ==-check 182 | (lambda (v w) 183 | (lambdag@ (s) 184 | (cond 185 | ((unify-check v w s) => succeed) 186 | (else (fail s)))))) 187 | 188 | (define-syntax fresh 189 | (syntax-rules () 190 | ((_ (x ...) g ...) 191 | (lambdag@ (s) 192 | (let ((x (var 'x)) ...) 193 | ((all g ...) s)))))) 194 | 195 | (define-syntax conde 196 | (syntax-rules () 197 | ((_ c ...) (cond-aux ife c ...)))) 198 | 199 | (define-syntax all 200 | (syntax-rules () 201 | ((_ g ...) (all-aux bind g ...)))) 202 | 203 | (define-syntax alli 204 | (syntax-rules () 205 | ((_ g ...) (all-aux bindi g ...)))) 206 | 207 | (define-syntax condi 208 | (syntax-rules () 209 | ((_ c ...) (cond-aux ifi c ...)))) 210 | 211 | (define-syntax conda 212 | (syntax-rules () 213 | ((_ c ...) (cond-aux ifa c ...)))) 214 | 215 | (define-syntax condu 216 | (syntax-rules () 217 | ((_ c ...) (cond-aux ifu c ...)))) 218 | 219 | (define mplus 220 | (lambda (a-inf f) 221 | (case-inf a-inf 222 | (f) 223 | ((a) (choice a f)) 224 | ((a f0) (choice a 225 | (lambdaf@ () (mplus (f0) f))))))) 226 | 227 | (define bind 228 | (lambda (a-inf g) 229 | (case-inf a-inf 230 | (mzero) 231 | ((a) (g a)) 232 | ((a f) (mplus (g a) 233 | (lambdaf@ () (bind (f) g))))))) 234 | 235 | (define mplusi 236 | (lambda (a-inf f) 237 | (case-inf a-inf 238 | (f) 239 | ((a) (choice a f)) 240 | ((a f0) (choice a 241 | (lambdaf@ () (mplusi (f) f0))))))) 242 | 243 | (define bindi 244 | (lambda (a-inf g) 245 | (case-inf a-inf 246 | (mzero) 247 | ((a) (g a)) 248 | ((a f) (mplusi (g a) 249 | (lambdaf@ () (bindi (f) g))))))) 250 | 251 | (define-syntax all-aux 252 | (syntax-rules () 253 | ((_ bnd) succeed) 254 | ((_ bnd g) g) 255 | ((_ bnd g0 g ...) 256 | (let ((g^ g0)) 257 | (lambdag@ (s) 258 | (bnd (g^ s) 259 | (lambdag@ (s) ((all-aux bnd g ...) s)))))))) 260 | 261 | (define-syntax cond-aux 262 | (syntax-rules (else) 263 | ((_ ifer) fail) 264 | ((_ ifer (else g ...)) (all g ...)) 265 | ((_ ifer (g ...)) (all g ...)) 266 | ((_ ifer (g0 g ...) c ...) 267 | (ifer g0 268 | (all g ...) 269 | (cond-aux ifer c ...))))) 270 | 271 | (define-syntax ife 272 | (syntax-rules () 273 | ((_ g0 g1 g2) 274 | (lambdag@ (s) 275 | (mplus ((all g0 g1) s) (lambdaf@ () (g2 s))))))) 276 | 277 | (define-syntax ifi 278 | (syntax-rules () 279 | ((_ g0 g1 g2) 280 | (lambdag@ (s) 281 | (mplusi ((all g0 g1) s) (lambdaf@ () (g2 s))))))) 282 | 283 | (define-syntax ifa 284 | (syntax-rules () 285 | ((_ g0 g1 g2) 286 | (lambdag@ (s) 287 | (let ((s-inf (g0 s))) 288 | (case-inf s-inf 289 | (g2 s) 290 | ((s) (g1 s)) 291 | ((s f) (bind s-inf g1)))))))) 292 | 293 | (define-syntax ifu 294 | (syntax-rules () 295 | ((_ g0 g1 g2) 296 | (lambdag@ (s) 297 | (let ((s-inf (g0 s))) 298 | (case-inf s-inf 299 | (g2 s) 300 | ((s) (g1 s)) 301 | ((s f) (g1 s)))))))) -------------------------------------------------------------------------------- /src/test-manager/srfi-69-hash-tables.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define *default-bound* (- (expt 2 29) 3)) 21 | 22 | (define (%string-hash s ch-conv bound) 23 | (let ((hash 31) 24 | (len (string-length s))) 25 | (do ((index 0 (+ index 1))) 26 | ((>= index len) (modulo hash bound)) 27 | (set! hash (modulo (+ (* 37 hash) 28 | (char->integer (ch-conv (string-ref s index)))) 29 | *default-bound*))))) 30 | 31 | (define (string-hash s . maybe-bound) 32 | (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 33 | (%string-hash s (lambda (x) x) bound))) 34 | 35 | (define (string-ci-hash s . maybe-bound) 36 | (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 37 | (%string-hash s char-downcase bound))) 38 | 39 | (define (symbol-hash s . maybe-bound) 40 | (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 41 | (%string-hash (symbol->string s) (lambda (x) x) bound))) 42 | 43 | (define (hash obj . maybe-bound) 44 | (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound)))) 45 | (cond ((integer? obj) (modulo obj bound)) 46 | ((string? obj) (string-hash obj bound)) 47 | ((symbol? obj) (symbol-hash obj bound)) 48 | ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound)) 49 | ((number? obj) 50 | (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj)))) 51 | bound)) 52 | ((char? obj) (modulo (char->integer obj) bound)) 53 | ((vector? obj) (vector-hash obj bound)) 54 | ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj)))) 55 | bound)) 56 | ((null? obj) 0) 57 | ((not obj) 0) 58 | ((procedure? obj) (error "hash: procedures cannot be hashed" obj)) 59 | (else 1)))) 60 | 61 | (define hash-by-identity hash) 62 | 63 | (define (vector-hash v bound) 64 | (let ((hashvalue 571) 65 | (len (vector-length v))) 66 | (do ((index 0 (+ index 1))) 67 | ((>= index len) (modulo hashvalue bound)) 68 | (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index))) 69 | *default-bound*))))) 70 | 71 | (define %make-hash-node cons) 72 | (define %hash-node-set-value! set-cdr!) 73 | (define %hash-node-key car) 74 | (define %hash-node-value cdr) 75 | 76 | (define-record-type 77 | (%make-hash-table size hash compare associate entries) 78 | hash-table? 79 | (size hash-table-size hash-table-set-size!) 80 | (hash hash-table-hash-function) 81 | (compare hash-table-equivalence-function) 82 | (associate hash-table-association-function) 83 | (entries hash-table-entries hash-table-set-entries!)) 84 | 85 | (define *default-table-size* 64) 86 | 87 | (define (appropriate-hash-function-for comparison) 88 | (or (and (eq? comparison eq?) hash-by-identity) 89 | (and (eq? comparison string=?) string-hash) 90 | (and (eq? comparison string-ci=?) string-ci-hash) 91 | hash)) 92 | 93 | (define (make-hash-table . args) 94 | (let* ((comparison (if (null? args) equal? (car args))) 95 | (hash 96 | (if (or (null? args) (null? (cdr args))) 97 | (appropriate-hash-function-for comparison) (cadr args))) 98 | (size 99 | (if (or (null? args) (null? (cdr args)) (null? (cddr args))) 100 | *default-table-size* (caddr args))) 101 | (association 102 | (or (and (eq? comparison eq?) assq) 103 | (and (eq? comparison eqv?) assv) 104 | (and (eq? comparison equal?) assoc) 105 | (letrec 106 | ((associate 107 | (lambda (val alist) 108 | (cond ((null? alist) #f) 109 | ((comparison val (caar alist)) (car alist)) 110 | (else (associate val (cdr alist))))))) 111 | associate)))) 112 | (%make-hash-table 0 hash comparison association (make-vector size '())))) 113 | 114 | (define (make-hash-table-maker comp hash) 115 | (lambda args (apply make-hash-table (cons comp (cons hash args))))) 116 | (define make-symbol-hash-table 117 | (make-hash-table-maker eq? symbol-hash)) 118 | (define make-string-hash-table 119 | (make-hash-table-maker string=? string-hash)) 120 | (define make-string-ci-hash-table 121 | (make-hash-table-maker string-ci=? string-ci-hash)) 122 | (define make-integer-hash-table 123 | (make-hash-table-maker = modulo)) 124 | 125 | (define (%hash-table-hash hash-table key) 126 | ((hash-table-hash-function hash-table) 127 | key (vector-length (hash-table-entries hash-table)))) 128 | 129 | (define (%hash-table-find entries associate hash key) 130 | (associate key (vector-ref entries hash))) 131 | 132 | (define (%hash-table-add! entries hash key value) 133 | (vector-set! entries hash 134 | (cons (%make-hash-node key value) 135 | (vector-ref entries hash)))) 136 | 137 | (define (%hash-table-delete! entries compare hash key) 138 | (let ((entrylist (vector-ref entries hash))) 139 | (cond ((null? entrylist) #f) 140 | ((compare key (caar entrylist)) 141 | (vector-set! entries hash (cdr entrylist)) #t) 142 | (else 143 | (let loop ((current (cdr entrylist)) (previous entrylist)) 144 | (cond ((null? current) #f) 145 | ((compare key (caar current)) 146 | (set-cdr! previous (cdr current)) #t) 147 | (else (loop (cdr current) current)))))))) 148 | 149 | (define (%hash-table-walk proc entries) 150 | (do ((index (- (vector-length entries) 1) (- index 1))) 151 | ((< index 0)) (for-each proc (vector-ref entries index)))) 152 | 153 | (define (%hash-table-maybe-resize! hash-table) 154 | (let* ((old-entries (hash-table-entries hash-table)) 155 | (hash-length (vector-length old-entries))) 156 | (if (> (hash-table-size hash-table) hash-length) 157 | (let* ((new-length (* 2 hash-length)) 158 | (new-entries (make-vector new-length '())) 159 | (hash (hash-table-hash-function hash-table))) 160 | (%hash-table-walk 161 | (lambda (node) 162 | (%hash-table-add! new-entries 163 | (hash (%hash-node-key node) new-length) 164 | (%hash-node-key node) (%hash-node-value node))) 165 | old-entries) 166 | (hash-table-set-entries! hash-table new-entries))))) 167 | 168 | (define (hash-table-ref hash-table key . maybe-default) 169 | (cond ((%hash-table-find (hash-table-entries hash-table) 170 | (hash-table-association-function hash-table) 171 | (%hash-table-hash hash-table key) key) 172 | => %hash-node-value) 173 | ((null? maybe-default) 174 | (error "hash-table-ref: no value associated with" key)) 175 | (else ((car maybe-default))))) 176 | 177 | (define (hash-table-ref/default hash-table key default) 178 | (hash-table-ref hash-table key (lambda () default))) 179 | 180 | (define (hash-table-set! hash-table key value) 181 | (let ((hash (%hash-table-hash hash-table key)) 182 | (entries (hash-table-entries hash-table))) 183 | (cond ((%hash-table-find entries 184 | (hash-table-association-function hash-table) 185 | hash key) 186 | => (lambda (node) (%hash-node-set-value! node value))) 187 | (else (%hash-table-add! entries hash key value) 188 | (hash-table-set-size! hash-table 189 | (+ 1 (hash-table-size hash-table))) 190 | (%hash-table-maybe-resize! hash-table))))) 191 | 192 | (define (hash-table-update! hash-table key function . maybe-default) 193 | (let ((hash (%hash-table-hash hash-table key)) 194 | (entries (hash-table-entries hash-table))) 195 | (cond ((%hash-table-find entries 196 | (hash-table-association-function hash-table) 197 | hash key) 198 | => (lambda (node) 199 | (%hash-node-set-value! 200 | node (function (%hash-node-value node))))) 201 | ((null? maybe-default) 202 | (error "hash-table-update!: no value exists for key" key)) 203 | (else (%hash-table-add! entries hash key 204 | (function ((car maybe-default)))) 205 | (hash-table-set-size! hash-table 206 | (+ 1 (hash-table-size hash-table))) 207 | (%hash-table-maybe-resize! hash-table))))) 208 | 209 | (define (hash-table-update!/default hash-table key function default) 210 | (hash-table-update! hash-table key function (lambda () default))) 211 | 212 | (define (hash-table-delete! hash-table key) 213 | (if (%hash-table-delete! (hash-table-entries hash-table) 214 | (hash-table-equivalence-function hash-table) 215 | (%hash-table-hash hash-table key) key) 216 | (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1)))) 217 | 218 | (define (hash-table-exists? hash-table key) 219 | (and (%hash-table-find (hash-table-entries hash-table) 220 | (hash-table-association-function hash-table) 221 | (%hash-table-hash hash-table key) key) #t)) 222 | 223 | (define (hash-table-walk hash-table proc) 224 | (%hash-table-walk 225 | (lambda (node) (proc (%hash-node-key node) (%hash-node-value node))) 226 | (hash-table-entries hash-table))) 227 | 228 | (define (hash-table-fold hash-table f acc) 229 | (hash-table-walk hash-table 230 | (lambda (key value) (set! acc (f key value acc)))) 231 | acc) 232 | 233 | (define (alist->hash-table alist . args) 234 | (let* ((comparison (if (null? args) equal? (car args))) 235 | (hash 236 | (if (or (null? args) (null? (cdr args))) 237 | (appropriate-hash-function-for comparison) (cadr args))) 238 | (size 239 | (if (or (null? args) (null? (cdr args)) (null? (cddr args))) 240 | (max *default-table-size* (* 2 (length alist))) (caddr args))) 241 | (hash-table (make-hash-table comparison hash size))) 242 | (for-each 243 | (lambda (elem) 244 | (hash-table-update!/default 245 | hash-table (car elem) (lambda (x) x) (cdr elem))) 246 | alist) 247 | hash-table)) 248 | 249 | (define (hash-table->alist hash-table) 250 | (hash-table-fold hash-table 251 | (lambda (key val acc) (cons (cons key val) acc)) '())) 252 | 253 | (define (hash-table-copy hash-table) 254 | (let ((new (make-hash-table (hash-table-equivalence-function hash-table) 255 | (hash-table-hash-function hash-table) 256 | (max *default-table-size* 257 | (* 2 (hash-table-size hash-table)))))) 258 | (hash-table-walk hash-table 259 | (lambda (key value) (hash-table-set! new key value))) 260 | new)) 261 | 262 | (define (hash-table-merge! hash-table1 hash-table2) 263 | (hash-table-walk 264 | hash-table2 265 | (lambda (key value) (hash-table-set! hash-table1 key value))) 266 | hash-table1) 267 | 268 | (define (hash-table-keys hash-table) 269 | (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '())) 270 | 271 | (define (hash-table-values hash-table) 272 | (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '())) 273 | -------------------------------------------------------------------------------- /src/kanren-book/mkprelude.scm: -------------------------------------------------------------------------------- 1 | ;;; Code that accompanies ``The Reasoned Schemer'' 2 | ;;; Daniel P. Friedman, William E. Byrd and Oleg Kiselyov 3 | ;;; MIT Press, Cambridge, MA, 2005 4 | ;;; 5 | ;;; Useful definitions from the book 6 | 7 | ;;; This file was generated by writeminikanren.pl 8 | ;;; Generated at 2005-08-12 11:27:16 9 | 10 | ;;; 3 October 2005 [WEB] 11 | ;;; Renamed 'any*' to 'anyo'. 12 | ;;; Renamed 'never' and 'always' to 'nevero' and 'alwayso'. 13 | 14 | (define caro 15 | (lambda (p a) 16 | (fresh (d) 17 | (== (cons a d) p)))) 18 | 19 | (define cdro 20 | (lambda (p d) 21 | (fresh (a) 22 | (== (cons a d) p)))) 23 | 24 | (define conso 25 | (lambda (a d p) 26 | (== (cons a d) p))) 27 | 28 | (define nullo 29 | (lambda (x) 30 | (== '() x))) 31 | 32 | (define eqo 33 | (lambda (x y) 34 | (== x y))) 35 | 36 | (define eq-caro 37 | (lambda (l x) 38 | (caro l x))) 39 | 40 | (define pairo 41 | (lambda (p) 42 | (fresh (a d) 43 | (conso a d p)))) 44 | 45 | (define listo 46 | (lambda (l) 47 | (conde 48 | ((nullo l) succeed) 49 | ((pairo l) 50 | (fresh (d) 51 | (cdro l d) 52 | (listo d))) 53 | (else fail)))) 54 | 55 | (define membero 56 | (lambda (x l) 57 | (conde 58 | ((nullo l) fail) 59 | ((eq-caro l x) succeed) 60 | (else 61 | (fresh (d) 62 | (cdro l d) 63 | (membero x d)))))) 64 | 65 | (define rembero 66 | (lambda (x l out) 67 | (conde 68 | ((nullo l) (== '() out)) 69 | ((eq-caro l x) (cdro l out)) 70 | (else (fresh (a d res) 71 | (conso a d l) 72 | (rembero x d res) 73 | (conso a res out)))))) 74 | 75 | (define appendo 76 | (lambda (l s out) 77 | (conde 78 | ((nullo l) (== s out)) 79 | (else 80 | (fresh (a d res) 81 | (conso a d l) 82 | (conso a res out) 83 | (appendo d s res)))))) 84 | 85 | (define anyo 86 | (lambda (g) 87 | (conde 88 | (g succeed) 89 | (else (anyo g))))) 90 | 91 | (define nevero (anyo fail)) 92 | 93 | (define alwayso (anyo succeed)) 94 | 95 | (define build-num 96 | (lambda (n) 97 | (cond 98 | ((zero? n) '()) 99 | ((and (not (zero? n)) (even? n)) 100 | (cons 0 101 | (build-num (quotient n 2)))) 102 | ((odd? n) 103 | (cons 1 104 | (build-num (quotient (- n 1) 2))))))) 105 | 106 | (define full-addero 107 | (lambda (b x y r c) 108 | (conde 109 | ((== 0 b) (== 0 x) (== 0 y) (== 0 r) (== 0 c)) 110 | ((== 1 b) (== 0 x) (== 0 y) (== 1 r) (== 0 c)) 111 | ((== 0 b) (== 1 x) (== 0 y) (== 1 r) (== 0 c)) 112 | ((== 1 b) (== 1 x) (== 0 y) (== 0 r) (== 1 c)) 113 | ((== 0 b) (== 0 x) (== 1 y) (== 1 r) (== 0 c)) 114 | ((== 1 b) (== 0 x) (== 1 y) (== 0 r) (== 1 c)) 115 | ((== 0 b) (== 1 x) (== 1 y) (== 0 r) (== 1 c)) 116 | ((== 1 b) (== 1 x) (== 1 y) (== 1 r) (== 1 c)) 117 | (else fail)))) 118 | 119 | (define poso 120 | (lambda (n) 121 | (fresh (a d) 122 | (== `(,a . ,d) n)))) 123 | 124 | (define >1o 125 | (lambda (n) 126 | (fresh (a ad dd) 127 | (== `(,a ,ad . ,dd) n)))) 128 | 129 | (define addero 130 | (lambda (d n m r) 131 | (condi 132 | ((== 0 d) (== '() m) (== n r)) 133 | ((== 0 d) (== '() n) (== m r) 134 | (poso m)) 135 | ((== 1 d) (== '() m) 136 | (addero 0 n '(1) r)) 137 | ((== 1 d) (== '() n) (poso m) 138 | (addero 0 '(1) m r)) 139 | ((== '(1) n) (== '(1) m) 140 | (fresh (a c) 141 | (== `(,a ,c) r) 142 | (full-addero d 1 1 a c))) 143 | ((== '(1) n) (gen-addero d n m r)) 144 | ((== '(1) m) (>1o n) (>1o r) 145 | (addero d '(1) n r)) 146 | ((>1o n) (gen-addero d n m r)) 147 | (else fail)))) 148 | 149 | (define gen-addero 150 | (lambda (d n m r) 151 | (fresh (a b c e x y z) 152 | (== `(,a . ,x) n) 153 | (== `(,b . ,y) m) (poso y) 154 | (== `(,c . ,z) r) (poso z) 155 | (alli 156 | (full-addero d a b c e) 157 | (addero e x y z))))) 158 | 159 | (define +o 160 | (lambda (n m k) 161 | (addero 0 n m k))) 162 | 163 | (define -o 164 | (lambda (n m k) 165 | (+o m k n))) 166 | 167 | (define *o 168 | (lambda (n m p) 169 | (condi 170 | ((== '() n) (== '() p)) 171 | ((poso n) (== '() m) (== '() p)) 172 | ((== '(1) n) (poso m) (== m p)) 173 | ((>1o n) (== '(1) m) (== n p)) 174 | ((fresh (x z) 175 | (== `(0 . ,x) n) (poso x) 176 | (== `(0 . ,z) p) (poso z) 177 | (>1o m) 178 | (*o x m z))) 179 | ((fresh (x y) 180 | (== `(1 . ,x) n) (poso x) 181 | (== `(0 . ,y) m) (poso y) 182 | (*o m n p))) 183 | ((fresh (x y) 184 | (== `(1 . ,x) n) (poso x) 185 | (== `(1 . ,y) m) (poso y) 186 | (odd-*o x n m p))) 187 | (else fail)))) 188 | 189 | (define odd-*o 190 | (lambda (x n m p) 191 | (fresh (q) 192 | (bound-*o q p n m) 193 | (*o x m q) 194 | (+o `(0 . ,q) m p)))) 195 | 196 | (define bound-*o 197 | (lambda (q p n m) 198 | (conde 199 | ((nullo q) (pairo p)) 200 | (else 201 | (fresh (x y z) 202 | (cdro q x) 203 | (cdro p y) 204 | (condi 205 | ((nullo n) 206 | (cdro m z) 207 | (bound-*o x y z '())) 208 | (else 209 | (cdro n z) 210 | (bound-*o x y z m)))))))) 211 | 212 | (define =lo 213 | (lambda (n m) 214 | (conde 215 | ((== '() n) (== '() m)) 216 | ((== '(1) n) (== '(1) m)) 217 | (else 218 | (fresh (a x b y) 219 | (== `(,a . ,x) n) (poso x) 220 | (== `(,b . ,y) m) (poso y) 221 | (=lo x y)))))) 222 | 223 | (define 1o m)) 228 | (else 229 | (fresh (a x b y) 230 | (== `(,a . ,x) n) (poso x) 231 | (== `(,b . ,y) m) (poso y) 232 | (1o b) (=lo n b) (+o r b n)) 325 | ((== '(1) b) (poso q) (+o r '(1) n)) 326 | ((== '() b) (poso q) (== r n)) 327 | ((== '(0 1) b) 328 | (fresh (a ad dd) 329 | (poso dd) 330 | (== `(,a ,ad . ,dd) n) 331 | (exp2 n '() q) 332 | (fresh (s) 333 | (splito n dd r s)))) 334 | ((fresh (a ad add ddd) 335 | (conde 336 | ((== '(1 1) b)) 337 | (else (== `(,a ,ad ,add . ,ddd) b)))) 338 | (1o n) (== '(1) q) 375 | (fresh (s) 376 | (splito n b s '(1)))) 377 | ((fresh (q1 b2) 378 | (alli 379 | (== `(0 . ,q1) q) 380 | (poso q1) 381 | (1o q) 400 | (fresh (q1 nq1) 401 | (+o q1 '(1) q) 402 | (repeated-mul n q1 nq1) 403 | (*o nq1 n nq))) 404 | (else fail)))) 405 | 406 | (define expo 407 | (lambda (b q n) 408 | (logo n b q '()))) 409 | 410 | ;;; 'trace-vars' can be used to print the values of selected variables 411 | ;;; in the substitution. 412 | (define-syntax trace-vars 413 | (syntax-rules () 414 | ((_ title x ...) 415 | (lambdag@ (s) 416 | (begin 417 | (printf "~a~n" title) 418 | (for-each (lambda (x_ t) 419 | (printf "~a = ~s~n" x_ t)) 420 | `(x ...) (reify (walk* `(,x ...) s))) 421 | (unit s)))))) 422 | 423 | ;;; (run* (q) 424 | ;;; (fresh (r) 425 | ;;; (== 3 q) 426 | ;;; (trace-vars "What it is!" q r))) 427 | ;;; 428 | ;;; What it is! 429 | ;;; q = 3 430 | ;;; r = _.0 431 | ;;; (3) 432 | -------------------------------------------------------------------------------- /src/test-manager/all-tests.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Test Manager is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-test (test-structure-smoke) 21 | (let ((mock-test-group (make-test-group 'mockery))) 22 | (with-top-level-group 23 | mock-test-group 24 | (lambda () 25 | (define-test (foo) 26 | foo!))) 27 | (assert-= 1 (tg:size mock-test-group)) 28 | (assert-true (single-test? (tg:get mock-test-group '(foo)))))) 29 | 30 | (define-test (test-structure) 31 | (let ((mock-test-group (make-test-group 'mockery))) 32 | (with-top-level-group 33 | mock-test-group 34 | (lambda () 35 | (in-test-group 36 | subgroup-1 37 | (define-test (some-name) foo!) 38 | (define-test (repeated-name) bar!)) 39 | (in-test-group 40 | subgroup-2 41 | (define-test (some-other-name) baz!) 42 | (define-test (repeated-name) quux!)))) 43 | (assert-= 2 (tg:size mock-test-group)) 44 | (assert-true (test-group? (tg:get mock-test-group '(subgroup-1)))) 45 | (assert-true (test-group? (tg:get mock-test-group '(subgroup-2)))) 46 | (let ((fetched-tests 47 | (map (lambda (test-path) 48 | (assert-eq (tg:get mock-test-group test-path) 49 | (tg:get mock-test-group test-path)) 50 | (tg:get mock-test-group test-path)) 51 | '((subgroup-1 some-name) 52 | (subgroup-1 repeated-name) 53 | (subgroup-2 some-other-name) 54 | (subgroup-2 repeated-name))))) 55 | (for-each (lambda (test) 56 | (assert-true (single-test? test))) 57 | fetched-tests)) 58 | (assert-false 59 | (eq? (tg:get mock-test-group '(subgroup-1 repeated-name)) 60 | (tg:get mock-test-group '(subgroup-2 repeated-name)))))) 61 | 62 | (in-test-group 63 | event-tracking-tests 64 | (let ((mock-test-group (make-test-group 'mockery)) 65 | (events '())) 66 | (define (add-event event) 67 | (set! events (cons event events))) 68 | (define-set-up 69 | (set! events '()) 70 | (set! mock-test-group (make-test-group 'mockery)) 71 | (with-top-level-group 72 | mock-test-group 73 | (lambda () 74 | (define-group-surround 75 | (add-event 'top-group-surround-begin) 76 | (run-test) 77 | (add-event 'top-group-surround-end)) 78 | (define-group-set-up (add-event 'top-group-set-up)) 79 | (define-group-tear-down (add-event 'top-group-tear-down)) 80 | (define-surround 81 | (add-event 'top-surround-begin) 82 | (run-test) 83 | (add-event 'top-surround-end)) 84 | (define-set-up (add-event 'top-set-up)) 85 | (define-tear-down (add-event 'top-tear-down)) 86 | (in-test-group 87 | group-a 88 | (define-group-surround 89 | (add-event 'a-group-surround-begin) 90 | (run-test) 91 | (add-event 'a-group-surround-end)) 92 | (define-group-set-up (add-event 'a-group-set-up)) 93 | (define-group-tear-down (add-event 'a-group-tear-down)) 94 | (define-surround 95 | (add-event 'a-surround-begin) 96 | (run-test) 97 | (add-event 'a-surround-end)) 98 | (define-set-up (add-event 'a-set-up)) 99 | (define-tear-down (add-event 'a-tear-down)) 100 | (define-test (test-a1) 101 | (add-event 'test-a1) 102 | (assert-= 5 (+ 2 2))) 103 | (define-test (test-a2) 104 | (add-event 'test-a2) 105 | (assert-equal '() #f))) 106 | (in-test-group 107 | group-b 108 | (define-group-surround 109 | (add-event 'b-group-surround-begin) 110 | (run-test) 111 | (add-event 'b-group-surround-end)) 112 | (define-group-set-up (add-event 'b-group-set-up)) 113 | (define-group-tear-down (add-event 'b-group-tear-down)) 114 | (define-surround 115 | (add-event 'b-surround-begin) 116 | (run-test) 117 | (add-event 'b-surround-end)) 118 | (define-set-up (add-event 'b-set-up)) 119 | (define-tear-down (add-event 'b-tear-down)) 120 | (define-test (test-b1) 121 | (add-event 'test-b1) 122 | (foo)) 123 | (define-test (test-b2) 124 | (add-event 'test-b2) 125 | (assert-= 4 (+ 2 (/ 2 0)))))))) 126 | (define-test (test-running) 127 | (let ((result-string 128 | (with-output-to-string 129 | (lambda () 130 | (with-top-level-group 131 | mock-test-group 132 | (lambda () 133 | (run-registered-tests))))))) 134 | (assert-matches 135 | "4 tests, 2 failures, 2 errors" 136 | result-string)) 137 | (assert-equal 138 | ;; Beware, the indentation in this list was produced manually 139 | '(top-group-surround-begin top-group-set-up 140 | top-surround-begin top-set-up 141 | a-group-surround-begin a-group-set-up 142 | a-surround-begin a-set-up test-a1 a-tear-down a-surround-end 143 | a-surround-begin a-set-up test-a2 a-tear-down a-surround-end 144 | a-group-tear-down a-group-surround-end 145 | top-tear-down top-surround-end 146 | top-surround-begin top-set-up 147 | b-group-surround-begin b-group-set-up 148 | b-surround-begin b-set-up test-b1 b-tear-down b-surround-end 149 | b-surround-begin b-set-up test-b2 b-tear-down b-surround-end 150 | b-group-tear-down b-group-surround-end 151 | top-tear-down top-surround-end 152 | top-group-tear-down top-group-surround-end) 153 | (reverse events))) 154 | (define-test (test-running-one-test) 155 | (let ((result-string 156 | (with-output-to-string 157 | (lambda () 158 | (with-top-level-group 159 | mock-test-group 160 | (lambda () 161 | (run-test '(group-b test-b1)))))))) 162 | (assert-matches 163 | "1 tests, 0 failures, 1 errors" 164 | result-string)) 165 | (assert-equal 166 | ;; Beware, the indentation in this list was produced manually 167 | '(top-group-surround-begin top-group-set-up 168 | top-surround-begin top-set-up 169 | b-group-surround-begin b-group-set-up 170 | b-surround-begin b-set-up test-b1 b-tear-down b-surround-end 171 | b-group-tear-down b-group-surround-end 172 | top-tear-down top-surround-end 173 | top-group-tear-down top-group-surround-end) 174 | (reverse events))) 175 | (define-test (test-running-one-group) 176 | (let ((result-string 177 | (with-output-to-string 178 | (lambda () 179 | (with-top-level-group 180 | mock-test-group 181 | (lambda () 182 | (run-test '(group-a)))))))) 183 | (assert-matches 184 | "2 tests, 2 failures, 0 errors" 185 | result-string)) 186 | (assert-equal 187 | ;; Beware, the indentation in this list was produced manually 188 | '(top-group-surround-begin top-group-set-up 189 | top-surround-begin top-set-up 190 | a-group-surround-begin a-group-set-up 191 | a-surround-begin a-set-up test-a1 a-tear-down a-surround-end 192 | a-surround-begin a-set-up test-a2 a-tear-down a-surround-end 193 | a-group-tear-down a-group-surround-end 194 | top-tear-down top-surround-end 195 | top-group-tear-down top-group-surround-end) 196 | (reverse events))))) 197 | 198 | ;; TODO test error behavior, particularly of run-test 199 | 200 | (let ((entered-group #f)) 201 | (in-test-group 202 | a-test-group-with-surroundings 203 | (set-tg:group-set-up! (current-test-group) 204 | (lambda () 205 | (set! entered-group #t))) 206 | (define-test (check-enter-this-thunk-runs) 207 | (assert-eq #t entered-group)))) 208 | 209 | (define (run-test-capturing-output name-stack) 210 | (with-output-to-string 211 | (lambda () 212 | (run-test name-stack)))) 213 | 214 | (define-test (test-explicit-run) 215 | (let ((count1 0) 216 | (count2 0) 217 | (mock-test-group (make-test-group 'mockery))) 218 | (with-top-level-group 219 | mock-test-group 220 | (lambda () 221 | (in-test-group 222 | sub1 223 | (in-test-group 224 | sub2 225 | (define-test (test1) 226 | (set! count1 (+ count1 1))) 227 | (define-test (test2) 228 | (set! count2 (+ count2 1))))) 229 | (assert-= 0 count1) 230 | (assert-= 0 count2) 231 | (run-test-capturing-output '(sub1 sub2 test1)) 232 | (assert-= 1 count1) 233 | (assert-= 0 count2) 234 | (run-test-capturing-output '(sub1 sub2)) 235 | (assert-= 2 count1) 236 | (assert-= 1 count2) 237 | (run-test-capturing-output '(sub1 sub2 test2)) 238 | (assert-= 2 count1) 239 | (assert-= 2 count2))))) 240 | 241 | (define-test (test-anonymous-syntax) 242 | (let ((mock-test-group (make-test-group 'mockery))) 243 | (with-top-level-group 244 | mock-test-group 245 | (lambda () 246 | (define-test () 247 | (this is an anonymous test)) 248 | (define-test (so is this)))) 249 | (assert-equal 2 (tg:size mock-test-group)))) 250 | 251 | (define-test (test-many-anonymous-syntax) 252 | (let ((mock-test-group (make-test-group 'mockery))) 253 | (with-top-level-group 254 | mock-test-group 255 | (lambda () 256 | (define-each-test) 257 | (define-each-test 258 | (foo) 259 | (bar) 260 | (baz)))) 261 | (assert-equal 3 (tg:size mock-test-group)))) 262 | 263 | (define-test (test-docstrings) 264 | (with-top-level-group 265 | (make-test-group 'mockery) 266 | (lambda () 267 | (define-test (foo) 268 | "This is the foo docstring" 269 | (assert-true #t)) 270 | (define-test (bar) 271 | "This is the bar docstring" 272 | (assert-true #f)) 273 | (define-test (assert-false #f)) 274 | (define-test (assert-false #t)) 275 | (assert-matches 276 | "This is the bar docstring" 277 | (run-test-capturing-output '(bar))) 278 | (assert-no-match 279 | "This is the foo docstring" 280 | (run-test-capturing-output '(foo))) 281 | (assert-matches 282 | "(assert-false #t)" 283 | (run-test-capturing-output '())) 284 | (assert-no-match 285 | "(assert-false #f)" 286 | (run-test-capturing-output '()))))) 287 | 288 | (define-test (test-definition-clearing) 289 | (let ((mock-group (make-test-group 'mockery))) 290 | (with-top-level-group 291 | mock-group 292 | (lambda () 293 | (define-test (foo) quux) 294 | (define-test (bar) baz) 295 | (define-test (ninja) monkey))) 296 | (assert= 3 (tg:size mock-group)) 297 | (assert-true (single-test? (tg:get mock-group '(foo)))) 298 | (assert-true (single-test? (tg:get mock-group '(bar)))) 299 | (assert-true (single-test? (tg:get mock-group '(ninja)))) 300 | (omap:remove! (tg:test-map mock-group) 'foo) 301 | (assert= 2 (tg:size mock-group)) 302 | (assert-false (tg:get mock-group '(foo))) 303 | (assert-true (single-test? (tg:get mock-group '(bar)))) 304 | (assert-true (single-test? (tg:get mock-group '(ninja)))) 305 | (with-top-level-group 306 | mock-group 307 | (lambda () 308 | (clear-registered-tests!))) 309 | (assert= 0 (tg:size mock-group)) 310 | (assert-false (tg:get mock-group '(foo))) 311 | (assert-false (tg:get mock-group '(bar))) 312 | (assert-false (tg:get mock-group '(ninja))))) 313 | 314 | (define-test (test-assert-generation) 315 | (with-top-level-group 316 | (make-test-group 'mockery) 317 | (lambda () 318 | (define-test (foo) 319 | (assert-equal 2 3)) 320 | (assert-matches 321 | "<2> expected to be equal\\? to\n<3>" 322 | (run-test-capturing-output '(foo)))))) 323 | 324 | (define-test (test-delayed-computation) 325 | (with-top-level-group 326 | (make-test-group 'mockery) 327 | (lambda () 328 | (define-test (passing-does-not-trigger-delays) 329 | (assert-equal 2 2 (delay (pp "Should not happen")))) 330 | (define-test (failing-does-trigger-delays) 331 | (assert-equal 2 3 (delay (pp "Should happen")))) 332 | (assert-matches 333 | "1 tests, 0 failures, 0 errors" 334 | (run-test-capturing-output '(passing-does-not-trigger-delays))) 335 | (assert-no-match 336 | "happen" 337 | (run-test-capturing-output '(passing-does-not-trigger-delays))) 338 | (assert-matches 339 | "happen" 340 | (run-test-capturing-output '(failing-does-trigger-delays))) 341 | (assert-matches 342 | "1 tests, 1 failures, 0 errors" 343 | (run-test-capturing-output '(failing-does-trigger-delays)))))) 344 | 345 | (define-test (test-check-captures-info) 346 | (with-top-level-group 347 | (make-test-group 'mockery) 348 | (lambda () 349 | (let ((foo 7) (bar 8)) 350 | (define-test (arguments-for-check) 351 | (check (> foo bar)))) 352 | (assert-matches 353 | "1 tests, 1 failures, 0 errors" 354 | (run-test-capturing-output '(arguments-for-check))) 355 | (assert-matches 356 | "(> foo bar)" 357 | (run-test-capturing-output '(arguments-for-check))) 358 | (assert-matches 359 | "(7 8)" 360 | (run-test-capturing-output '(arguments-for-check)))))) 361 | 362 | (define-test (test-define-each-check) 363 | (with-top-level-group 364 | (make-test-group 'mockery) 365 | (lambda () 366 | (in-test-group subgroup 367 | (define-each-check 368 | (even? (* 2 3)) 369 | (odd? (* 4 3)) 370 | (even? (+ 6 1)) 371 | (odd? (+ 8 1)))) 372 | (assert-matches 373 | "4 tests, 2 failures, 0 errors" 374 | (run-test-capturing-output '(subgroup))) 375 | (check (string-search-forward 376 | "(odd? (* 4 3))" 377 | (run-test-capturing-output '(subgroup)))) 378 | (assert-matches 379 | "(12)" 380 | (run-test-capturing-output '(subgroup))) 381 | (check (string-search-forward 382 | "(even? (+ 6 1))" 383 | (run-test-capturing-output '(subgroup)))) 384 | (assert-matches 385 | "(7)" 386 | (run-test-capturing-output '(subgroup)))))) 387 | 388 | (define-test (interactions) 389 | (interaction 390 | (define foo 5) 391 | (+ foo 2) 392 | (produces 7) 393 | ((if (even? 4) * +) 3 5) 394 | (produces 15))) 395 | 396 | ;; MIT Scheme specific features 397 | (cond-expand 398 | (guile 399 | 'ok) 400 | (else 401 | (load-relative "mit-scheme-tests"))) 402 | -------------------------------------------------------------------------------- /src/test-manager/doc/testing.pod: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------- 2 | Copyright 2007-2008 Alexey Radul. 3 | ---------------------------------------------------------------------- 4 | This file is part of Test Manager. 5 | 6 | Test Manager is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation, either version 3 of the License, or 9 | (at your option) any later version. 10 | 11 | Test Manager is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with Test Manager. If not, see . 18 | ---------------------------------------------------------------------- 19 | 20 | =pod 21 | 22 | =head1 NAME 23 | 24 | test-manager/ - An automatic unit-testing framework for MIT Scheme 25 | 26 | =head1 SYNOPSYS 27 | 28 | (load "test-manager/load.scm") 29 | 30 | ; This is a test group named simple-stuff 31 | (in-test-group 32 | simple-stuff 33 | 34 | ; This is one test named arithmetic 35 | (define-test (arithmetic) 36 | "Checking that set! and arithmetic work" 37 | (define foo 5) 38 | (check (= 5 foo) "Foo should start as five.") 39 | (set! foo 6) 40 | (check (= 36 (* foo foo)))) 41 | 42 | ; Each of these will become a separate anonymous one-form test 43 | (define-each-test 44 | (check (= 4 (+ 2 2)) "Two and two should make four.") 45 | (check (= 2147483648 (+ 2147483647 1)) "Addition shouldn't overflow.")) 46 | 47 | ; Each of these will become a separate anonymous one-form test using check 48 | (define-each-check 49 | (= 6 (+ 2 2 2)) 50 | (equal? '(1 2 3) (cons 1 '(2 3)))) 51 | 52 | ; This is a test that looks like a REPL interaction 53 | (define-test (interactive) 54 | (interaction 55 | (define foo 5) 56 | foo 57 | (produces 5) ; This compares against the value of the last form 58 | (set! foo 6) 59 | (* foo foo) 60 | (produces 36)))) 61 | 62 | (run-registered-tests) 63 | 64 | ; Can run individual groups or tests with 65 | (run-test '(simple-stuff)) 66 | (run-test '(simple-stuff arithmetic)) 67 | 68 | =head1 DESCRIPTION 69 | 70 | This test framework defines a language for specifying test suites and 71 | a simple set of commands for running them. A test suite is a 72 | collection of individual tests grouped into a hierarchy of test 73 | groups. The test group hierarchy serves to semantically aggregate the 74 | tests, allowing the definition of shared code for set up, tear down, 75 | and surround, and also partition the test namespace to avoid 76 | collisions. 77 | 78 | The individual tests are ordinary procedures, with some associated 79 | bookkeeping. A test is considered to pass if it returns normally, 80 | and to fail if it raises some condition that it does not handle 81 | (tests escaping into continuations leads to unspecified behavior). 82 | 83 | The framework provides a C macro and a library of assertion 84 | procedures that can be invoked in tests and have the desired behavior 85 | of raising an appropriate condition if they fail. The framework also 86 | provides an C macro, together with a C 87 | procedure, for simulating read-eval-print interactions, and an 88 | extensible pattern-matching facility for easier testing of the 89 | relevant aspects of a result while ignoring the irrelevant ones. 90 | 91 | =head2 Defining Test Suites 92 | 93 | All tests are grouped into a hierarchy of test groups. 94 | At any point in the definition of a test suite, there is an implicit 95 | "current test group", into which tests and subgroups can be added. By 96 | default, the current test group is the top-level test group, which is 97 | the root of the test group hierarchy. 98 | 99 | =over 100 | 101 | =item (define-test (name) expression ... ) 102 | 103 | Define a test named C that consists of the given expressions, 104 | and add it to the current test group. When the test is run, the 105 | expressions will be executed in order, just like the body of any 106 | procedure. If the test raises any condition that it does not handle, 107 | it is considered to have failed. If it returns normally, it is 108 | considered to have passed. Usually, tests will contain uses of the 109 | C macro or of assertions from the list below, which raise 110 | appropriate conditions when they fail. In the spirit of Lisp 111 | docstrings, if the first expression in the test body is a literal 112 | string, that string will be included in the failure report if the test 113 | should fail. 114 | 115 | This is the most verbose and most expressive test definition syntax. 116 | The four test definition syntaxes provided below are increasingly 117 | terse syntactic sugar for common usage patterns of this syntax. 118 | 119 | =item (define-test () expression ... ) 120 | 121 | Define an explicitly anonymous test. I can't see why you would want 122 | to do this, but it is provided for completeness. 123 | 124 | =item (define-test expression) 125 | 126 | Define a one-expression anonymous test. The single expression will be 127 | printed in the failure report if the test fails. This is a special 128 | case of C, below. 129 | 130 | =item (define-each-test expression ... ) 131 | 132 | Define a one-expression anonymous test for each of the given 133 | expressions. If any of the tests fail, the corresponding expression 134 | will be printed in that test's failure report. 135 | 136 | =item (define-each-check expression ...) 137 | 138 | Define a one-expression anonymous test for each of the given 139 | expressions by wrapping it in a use of the C macro, below. 140 | 141 | If you have many simple independent checks you need to make and 142 | you don't want to invent names for each individual one, this is the 143 | test definition syntax for you. 144 | 145 | =item (in-test-group name expression ... ) 146 | 147 | Locate (or create) a test subgroup called C in the current test 148 | group. Then temporarily make this subgroup the current test group, 149 | and execute the expressions in the body of C. This 150 | groups any tests and further subgroups defined by those expressions 151 | into this test group. Test groups can nest arbitrarily deep. Test 152 | groups serve to disambiguate the names of tests, and to group them 153 | semantically. In particular, should a test fail, the names of the 154 | stack of groups it's in will be displayed along with the test name 155 | itself. 156 | 157 | =item (define-set-up expression ...) 158 | 159 | Defines a sequence of expressions to be run before every test in 160 | the current test group. Clobbers any previously defined set up 161 | for this group. 162 | 163 | =item (define-tear-down expression ...) 164 | 165 | Defines a sequence of expressions to be run after every test in 166 | the current test group. Clobbers any previously defined tear down 167 | for this group. 168 | 169 | =item (define-surround expression ...) 170 | 171 | Defines a sequence of expressions to be run surrounding every test in 172 | the current test group. Inside the C, the identifier 173 | C is bound to a nullary procedure that actually runs the 174 | test. The test will get run as many times as you call C, so 175 | you can run each test under several conditions (or accidentally not 176 | run it at all if you forget to call C). Clobbers any 177 | previously defined surround for this group. 178 | 179 | =item (define-group-set-up expression ...) 180 | 181 | Defines a sequence of expressions to be run once before running any 182 | test in the current test group. Clobbers any previously defined group 183 | set up for this group. 184 | 185 | =item (define-group-tear-down expression ...) 186 | 187 | Defines a sequence of expressions to be run once after running all 188 | tests in the current test group. Clobbers any previously defined 189 | group tear down for this group. 190 | 191 | =item (define-group-surround expression ...) 192 | 193 | Defines a sequence of expressions to be run once surrounding running 194 | the tests in the current test group. Inside the 195 | C, the identifier C is bound to a 196 | nullary procedure that actually runs the tests in this group. 197 | Clobbers any previously defined group surround for this group. 198 | 199 | =back 200 | 201 | =head2 Running Test Suites 202 | 203 | The following procedures are provided for running test suites: 204 | 205 | =over 206 | 207 | =item (run-test name-stack) 208 | 209 | Looks up the test indicated by name-stack in the current test group, 210 | runs it, and prints a report of the results. Returns the number of 211 | tests that did not pass. An empty list for a name stack indicates the 212 | whole group, a singleton list indicates that immediate descendant, a 213 | two-element list indicates a descendant of a descendant, etc. For 214 | example, C<(run-test '(simple-stuff arithmetic))> would run the first 215 | test defined in the example at the top of this page. 216 | 217 | =item (run-registered-tests) 218 | 219 | Runs all tests registered so far, and prints a report of the results. 220 | Returns the number of tests that did not pass. This could have been 221 | defined as C<(run-test '())>. 222 | 223 | =item (clear-registered-tests!) 224 | 225 | Unregister all tests. Useful when loading and reloading test suites 226 | interactively. For more elaborate test structure manipulation 227 | facilities, see also test-group.scm. 228 | 229 | =back 230 | 231 | =head2 Checks 232 | 233 | The C macro is the main mechanism for asking tests to actually 234 | test something: 235 | 236 | =over 237 | 238 | =item (check expression [message]) 239 | 240 | Executes the expression, and passes iff that expression returns a true 241 | value (to wit, not #f). If the expression returns #f, constructs a 242 | failure report from the expression, the message if any, and the values 243 | of the immediate subexpressions of the expression. 244 | 245 | =back 246 | 247 | C is a macro so that it can examine the expression provided and 248 | construct a useful failure report if the expression does not return a 249 | true value. Specifically, the failure report includes the expression 250 | itself, as well as the values that all subexpressions (except the 251 | first) of that expression evaluated to. For example, 252 | 253 | (check (< (+ 2 5) (* 3 2))) 254 | 255 | fails and reports 256 | 257 | Form : (< (+ 2 5) (* 3 2)) 258 | Arg values: (7 6) 259 | 260 | so you can see right away both what failed, and, to some degree, what 261 | the problem was. 262 | 263 | In the event that the failure report generated by C itself is 264 | inadequate, C also accepts an optional second argument that is 265 | interpreted as a user-supplied message to be added to the failure 266 | report. The message can be either a string, or an arbitrary object 267 | that will be coerced to a string by C, or a promise (as 268 | created by C), which will be forced and the result coerced to a 269 | string. The latter is useful for checks with dynamically computed 270 | messages, because that computation will then only be performed if the 271 | test actually fails, and in general for doing some computation at 272 | check failure time. 273 | 274 | =head2 Interactions 275 | 276 | The style of interactively fooling with a piece of code at the 277 | read-eval-print loop differs from the style of writing units tests for 278 | a piece of code and running them. One notable difference is that at 279 | the REPL you write some expression and examine its return value to see 280 | whether it was what you expected, whereas when writing a unit test you 281 | write a check form that contains both the expression under test and 282 | the criterion you expect it to satisfy. In order to decrease the 283 | impedance mismatch between these two ways of verifying what a program 284 | does, C provides the procedure C, which 285 | retroactively checks the last return value, and the macro 286 | C, which enables C to work inside a unit test. 287 | 288 | =over 289 | 290 | =item (produces pattern) 291 | 292 | Checks that the return value of the previous evaluated expression 293 | matches (via C, below) the provided pattern. This 294 | works at the REPL via the REPL history, and also works inside a use of 295 | the C macro. 296 | 297 | =item (interation form ...) 298 | 299 | Tracks the return values of each C
and makes them available for 300 | use with C. For an example, see the last test in the 301 | synopsis. 302 | 303 | =back 304 | 305 | =head2 Pattern Matching 306 | 307 | The user-extensible pattern matching facility is the generic procedure 308 | C. This procedure is generic in the sense of the 309 | Scheme Object System provided with MIT Scheme. It can be used in 310 | tests directly, and is automatically invoked by C above, and 311 | C and C below. 312 | 313 | =over 314 | 315 | =item (generic-match pattern object) 316 | 317 | Returns #t iff the given object matches the given pattern. The 318 | meaning of "matches" is user-extensible by adding methods to this 319 | generic procedure. By default compares whether the pattern is 320 | C to the object, but also see provided methods below. 321 | 322 | =item (generic-match pattern-string string) 323 | 324 | If the pattern and the object are strings, interprets the pattern 325 | as a regular expression and matches it against the object. 326 | 327 | =item (generic-match pattern-pair pair) 328 | 329 | If the pattern and the object are pairs, recursively matches their 330 | Cs and Cs against each other. 331 | 332 | =item (generic-match pattern-vector vector) 333 | 334 | If the pattern and the object are vectors, recursively matches their 335 | components against each other elementwise. 336 | 337 | =item (generic-match x y) 338 | 339 | If the pattern and the object are inexact numbers, checks them for 340 | equality, and then then checks whether the object rounded to five 341 | significant digits equals the pattern. For example, C<(generic-match 342 | 1.4142 (sqrt 2))> returns #t, as does 343 | C<(generic-match 1.4142135623730951 (sqrt 2))>. 344 | 345 | =back 346 | 347 | =head2 Assertions 348 | 349 | The following assertion procedures are provided for situations where 350 | C being a macro makes it unweildy. The C arguments to 351 | the assertions are user-specified messages to print to the output if 352 | the given assertion fails. The C assertion requires a 353 | message argument because it cannot construct a useful output without 354 | one, and because it is not really meant for extensive direct use. The 355 | message is optional for the other assertions because they can say 356 | something at least mildly informative even without a user-supplied 357 | message. In any case, the message arguments are treated the same way 358 | as by C. 359 | 360 | =over 361 | 362 | =item (assert-proc message proc) 363 | 364 | Passes iff the given procedure, invoked with no arguments, returns a 365 | true value. On failure, arranges for the given C to appear in 366 | the failure report. This is a primitive assertion in whose terms 367 | other assertions are defined. 368 | 369 | =item (assert-true thing [message]) 370 | 371 | Passes iff the given value is a true value (to wit, not #f). 372 | 373 | =item (assert-false thing [message]) 374 | 375 | Passes iff the given value is a false value (to wit, #f). 376 | 377 | =item (assert-equal expected actual [message]) 378 | Likewise assert-eqv, assert-eq, and assert-= 379 | 380 | Passes iff the given C value is equivalent, according to the 381 | corresponding predicate, to the C value. Produces a 382 | reasonably helpful message on failure, and includes the optional 383 | C argument in it if present. When in doubt, use 384 | C to compare most things; use C to compare 385 | exact numbers like integers; and use C, below, for 386 | inexact numbers like floating points. 387 | 388 | =item assert-equals, assert= 389 | 390 | Are aliases for assert-equal and assert-=, respectively. 391 | 392 | =item (assert-equivalent predicate [pred-name]) 393 | 394 | This is intended as a tool for building custom assertions. Returns an 395 | assertion procedure that compares an expected and an actual value with 396 | the given predicate and produces a reasonable failure message. 397 | C and company could have been defined in terms of 398 | C as, for example, C<(define assert-equal 399 | (assert-equivalent equal? "equal?"))>. 400 | 401 | =item assert-< assert-> assert-<= assert->= 402 | 403 | Like assert-=, but with a different comparator. In particular, these 404 | aren't equivalence relations, so the order of arguments matters. 405 | 406 | =item (assert-matches pattern object [message]) 407 | 408 | Passes iff the given object matches the given pattern, per 409 | C. 410 | 411 | =item (assert-no-match pattern object [message]) 412 | 413 | Passes iff the given object does not match the given pattern, likewise 414 | per C. 415 | 416 | =item (assert-in-delta expected actual delta [message]) 417 | 418 | Passes iff the given C value differs, in absolute value, from 419 | the given C value by no more than C. Use this in 420 | preference to C to check sameness of inexact numerical 421 | values. 422 | 423 | =back 424 | 425 | =head1 PORTABILITY 426 | 427 | I originally started this project with MIT Scheme and Guile in mind as 428 | target Scheme implementations. That aim met with success through 429 | version 1.1, but as of version 1.2 I dropped explicit support for the 430 | Guile port. I have left all the portability code intact; the vast 431 | majority of the documented features should work in Guile. Also, since 432 | this software has been two-Scheme for much of its life, I expect it 433 | should not be hard to port to other Schemes. 434 | 435 | The specific things that I know do not work in Guile are: C 436 | does not work in the Guile REPL (though it does still work inside 437 | C) which rather defeats its purpose; C is 438 | not actually a generic procedure in Guile (though that could 439 | presumably be fixed by one who knew Guile's generic procedure 440 | facilities); and C does not accept a message argument in Guile. 441 | 442 | =head1 BUGS 443 | 444 | This unit testing framework is a work in progress. The test groups do 445 | not support as much shared set up code among their tests as I would 446 | like, and the language for explicit test group handling is 447 | ill-specified and undocumented (peruse test-group.scm if interested). 448 | Suggestions are welcome. 449 | 450 | =head1 AUTHOR 451 | 452 | Alexey Radul, axch@mit.edu 453 | 454 | =cut 455 | -------------------------------------------------------------------------------- /src/lil_00.scm: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; lil_00.scm - following along the little schemer book 3 | ;; 4 | 5 | ;; ch. 1 6 | ;; toys 7 | 8 | (define (atom? sexp) 9 | (and (not (pair? sexp)) (not (null? sexp)))) 10 | 11 | ;; ch. 2 12 | ;; do it, do it again 13 | 14 | (define (lat? xs) 15 | (cond ((null? xs) #t) 16 | ((atom? (car xs)) (lat? (cdr xs))) 17 | (else #f))) 18 | 19 | (define (member? x xs) 20 | (cond ((null? xs) #f) 21 | (else (or (eq? x (car xs)) 22 | (member? x (cdr xs)))))) 23 | 24 | ;; ch. 3 25 | ;; cons the magnificent 26 | 27 | (define (o-rember x xs) 28 | (cond ((null? xs) '()) 29 | ((eq? x (car xs)) (cdr xs)) 30 | (else (cons (car xs) (o-rember x (cdr xs)))))) 31 | 32 | (define (list-equal? xs ys) 33 | (cond ((null? xs) (null? ys)) 34 | ((null? ys) (null? xs)) 35 | ((eq? (car xs) (car ys)) (list-equal? (cdr xs) (cdr ys))) 36 | (else #f))) 37 | 38 | 39 | (define (firsts xs) 40 | (cond ((null? xs) '()) 41 | (else (cons (car (car xs)) 42 | (firsts (cdr xs)))))) 43 | 44 | (define (insertR new old lat) 45 | (cond ((null? lat) '()) 46 | (else 47 | (cond 48 | ((eq? (car lat) old) 49 | (cons old (cons new (cdr lat)))) 50 | (else 51 | (cons (car lat) 52 | (insertR new old (cdr lat)))))))) 53 | 54 | (define (insertL new old lat) 55 | (cond ((null? lat) '()) 56 | (else 57 | (cond 58 | ((eq? (car lat) old) 59 | (cons new lat)) 60 | (else 61 | (cons (car lat) 62 | (insertL new old (cdr lat)))))))) 63 | 64 | (define (subst new old lat) 65 | (cond ((null? lat) '()) 66 | (else 67 | (cond 68 | ((eq? (car lat) old) 69 | (cons new (cdr lat))) 70 | (else 71 | (cons (car lat) 72 | (subst new old (cdr lat)))))))) 73 | 74 | (define (multirember x xs) 75 | (cond ((null? xs) '()) 76 | ((eq? x (car xs)) (multirember x (cdr xs))) 77 | (else (cons (car xs) (multirember x (cdr xs)))))) 78 | 79 | ;; ch. 4 80 | ;; number games 81 | 82 | (define (myplus a b) 83 | (cond ((zero? a) b) 84 | (else (myplus (sub1 a) (add1 b))))) 85 | 86 | (define (addtup tup) 87 | (cond ((null? tup) 0) 88 | (else (+ (car tup) (addtup (cdr tup)))))) 89 | 90 | (define (xo a b) 91 | (cond ((= b 1) a) 92 | (else (+ a (xo a (sub1 b)))))) 93 | 94 | (define (tup+ tup1 tup2) 95 | (cond ((and (null? tup1) (null? tup2)) '()) 96 | (else 97 | (cons (+ (car tup1) (car tup2)) (tup+ (cdr tup1) (cdr tup2)))))) 98 | 99 | (define (gt a b) 100 | (cond 101 | ((zero? a) #f) 102 | ((zero? b) #t) 103 | (else (gt (sub1 a) (sub1 b))))) 104 | 105 | (define (expo n f) 106 | (cond ((zero? f) 1) 107 | (else (* n (expo n (sub1 f)))))) 108 | 109 | (define (lng lat) 110 | (cond ((null? lat) 0) 111 | (else (add1 (lng (cdr lat)))))) 112 | 113 | (define (pick n lat) 114 | (cond ((zero? (sub1 n)) (car lat)) 115 | (else (pick (sub1 n) (cdr lat))))) 116 | 117 | (define (rempick n lat) 118 | (cond ((zero? (sub1 n)) (cdr lat)) 119 | (else (cons (car lat) (rempick (sub1 n) (cdr lat)))))) 120 | 121 | ;; ch. 5 122 | ;; full of stars 123 | 124 | (define (rember* a l) 125 | (cond ((null? l) '()) 126 | ((atom? (car l)) 127 | (cond ((eq? a (car l)) (rember* a (cdr l))) 128 | (else (cons (car l) (rember* a (cdr l)))))) 129 | (else (cons (rember* a (car l)) (rember* a (cdr l)))))) 130 | 131 | (define (occur* a l) 132 | (cond ((null? l) 0) 133 | ((atom? (car l)) 134 | (cond ((eq? a (car l)) (+ 1 (occur* a (cdr l)))) 135 | (else (occur* a (cdr l))))) 136 | (else (+ (occur* a (car l)) 137 | (occur* a (cdr l)))))) 138 | 139 | (define (member* a l) 140 | (cond ((null? l) #f) 141 | ((atom? (car l)) (or (eq? a (car l)) (member* a (cdr l)))) 142 | (else (or (member* a (car l)) (member* a (cdr l)))))) 143 | 144 | (define myxs '(foo (bar cup) god (foo cup cup) (((cup)) doo))) 145 | 146 | ;; ch. 6 147 | ;; shadows 148 | 149 | (define (numbered? aexp) 150 | (cond ((atom? aexp) (number? aexp)) 151 | (else (and (numbered? (car aexp)) 152 | (numbered? (caddr aexp)))))) 153 | 154 | (numbered? '(5 + (3 ^ 7))) 155 | 156 | (define (value nexp) 157 | (cond ((atom? nexp) nexp) 158 | ((eq? (cadr nexp) '+) 159 | (+ (value (car nexp)) (value (caddr nexp)))) 160 | ((eq? (cadr nexp) 'x) 161 | (* (value (car nexp)) (value (caddr nexp)))))) 162 | 163 | (value '(3 + 5)) 164 | (value '(3 x 5)) 165 | (value '(3 x (2 + 12))) 166 | 167 | (define 1st-sub-expr cadr) 168 | (define 2nd-sub-expr caddr) 169 | (define operator car) 170 | 171 | (define (valuep nexp) 172 | (cond ((atom? nexp) nexp) 173 | ((eq? (operator nexp) '+) 174 | (+ (valuep (1st-sub-expr nexp)) (value (2nd-sub-expr nexp)))) 175 | ((eq? (operator nexp) 'x) 176 | (* (valuep (1st-sub-expr nexp)) (value (2nd-sub-expr nexp)))))) 177 | 178 | (valuep '(+ (x 4 4) 8)) 179 | 180 | ;; ch. 7 181 | ;; friends and relations 182 | 183 | (define (set? lat) 184 | (cond ((null? lat) #t) 185 | ((member? (car lat) (cdr lat)) #f) 186 | (else (set? (cdr lat))))) 187 | 188 | (eq? #t (set? '(a b c d))) 189 | (eq? #f (set? '(a b c d c))) 190 | (eq? #f (set? '(a b c 5 6 b))) 191 | 192 | ;; using `member?` 193 | (define (makeset lat) 194 | (cond ((null? lat) '()) 195 | ((member? (car lat) (cdr lat)) (makeset (cdr lat))) 196 | (else (cons (car lat) (makeset (cdr lat)))))) 197 | 198 | (equal? '(a b c d) (makeset '(a b c c d d))) 199 | 200 | ;; using `multirember` 201 | (define (makesetp lat) 202 | (cond ((null? lat) '()) 203 | (else (cons (car lat) (makesetp (multirember (car lat) (cdr lat))))))) 204 | 205 | (equal? '(a 3 b c d) (makesetp '(a 3 a b 3 c a c d d))) 206 | 207 | (define (subset? s1 s2) 208 | (cond ((null? s1) #t) 209 | (else (and (member? (car s1) s2) 210 | (subset? (cdr s1) s2))))) 211 | 212 | (eq? #t (subset? '(a b) '(e f b a))) 213 | (eq? #f (subset? '(a c) '(e f b a))) 214 | 215 | (define (eqset? s1 s2) 216 | (and (subset? s1 s2) (subset? s2 s1))) 217 | 218 | (eq? #t (eqset? '(a b c) '(c b a a b))) 219 | (eq? #t (eqset? '(a b c) '(c b a a b))) 220 | (eq? #f (eqset? '(a b c) '(c y b a a b))) 221 | 222 | (define (intersect? s1 s2) 223 | (cond ((null? s1) #f) 224 | (else (or (member? (car s1) s2) 225 | (intersect? (cdr s1) s2))))) 226 | 227 | (eq? #t (intersect? '(a b c) '(c d e f))) 228 | (eq? #f (intersect? '(a b c) '(d e f))) 229 | 230 | (define (intersect s1 s2) 231 | (cond ((null? s1) '()) 232 | ((member? (car s1) s2) 233 | (cons (car s1) (intersect (cdr s1) s2))) 234 | (else (intersect (cdr s1) s2)))) 235 | 236 | (equal? '(c d) (intersect '(a b c d e f) '(y d c x))) 237 | 238 | (define (union s1 s2) 239 | (cond ((null? s1) s2) 240 | ((member? (car s1) s2) (union (cdr s1) s2)) 241 | (else (cons (car s1) (union (cdr s1) s2))))) 242 | 243 | (equal? '(a b c d e f) (union '(a b c d) '(d e f))) 244 | 245 | (define (difference s1 s2) 246 | (cond ((null? s1) '()) 247 | ((member? (car s1) s2) (difference (cdr s1) s2)) 248 | (else (cons (car s1) (difference (cdr s1) s2))))) 249 | 250 | (equal? '(a b) (difference '(a b c d) '(c d e))) 251 | 252 | (define (intersectall l-set) 253 | (cond ((null? (cdr l-set)) (car l-set)) 254 | (else (intersect (car l-set) 255 | (intersectall (cdr l-set)))))) 256 | 257 | ;; evals to something like: 258 | ;; (isect car (isect car (isect car cdr))) 259 | 260 | ;; alt impl using reduce 261 | (define (intersectallp l-set) 262 | (reduce-left intersect '() l-set)) 263 | 264 | (equal? '(d e) (intersectall '((a b c d e f g) (f e d y) (d e g e)))) 265 | 266 | (define (a-pair? x) 267 | (cond ((atom? x) #f) 268 | ((null? x) #f) 269 | ((null? (cdr x)) #f) 270 | ((null? (cddr x)) #t) 271 | (else #f))) 272 | 273 | (eq? #t (a-pair? '(a b))) 274 | (eq? #t (a-pair? '(5 6))) 275 | (eq? #t (a-pair? '((g b) (i g)))) 276 | (eq? #f (a-pair? '(a b c))) 277 | 278 | (define fst car) 279 | (define snd cadr) 280 | 281 | (define (build s1 s2) 282 | (cons s1 (cons s2 '()))) 283 | 284 | (define (fun? rel) 285 | (set? (firsts rel))) 286 | 287 | (eq? #t (fun? '((a b) (c d) (5 g)))) 288 | (eq? #f (fun? '((a b) (c d) (a g)))) 289 | 290 | (define (revpair p) (build (snd p) (fst p))) 291 | 292 | (define (revrel rel) 293 | (cond ((null? rel) '()) 294 | (else (cons 295 | (revpair (car rel)) 296 | (revrel (cdr rel)))))) 297 | 298 | (revrel '((a b) (1 2))) 299 | 300 | (define (fullfun? fun) 301 | (fun? (revrel fun))) 302 | 303 | (define one-to-one? fullfun?) 304 | 305 | (eq? #t (fullfun? '((a b) (x y)))) 306 | (eq? #f (fullfun? '((x y) (a b) (v y)))) 307 | 308 | ;; ch. 8 309 | ;; lambda the ultimate 310 | 311 | ;; skipping basic higher order fn review.. 312 | 313 | ;; but this guy looks strange. we're creating 314 | ;; a new function on each recursion. the new 315 | ;; fn closes over lat free variable. 316 | 317 | (define (multirember-co a lat col) 318 | (cond 319 | ((null? lat) (col '() '())) 320 | ((eq? (car lat) a) 321 | (multirember-co 322 | a (cdr lat) 323 | (lambda (newlat seen) 324 | (col newlat (cons (car lat) seen))))) 325 | (else 326 | (multirember-co 327 | a (cdr lat) 328 | (lambda (newlat seen) 329 | (col (cons (car lat) newlat) seen)))))) 330 | 331 | (define (a-friend x y) (null? y)) 332 | 333 | (multirember-co 'tuna '() a-friend) 334 | ;; (a-friend '() '()) => #t 335 | 336 | (multirember-co 'tuna '(tuna) a-friend) 337 | ;; eval steps 338 | ;; 1. call fn, eq? true, so 339 | ;; 2. (multirember-co 'tuna '() f), f is a new fn, 340 | ;; of 2 args, which calls a-friend like.. 341 | ;; 3. (a-friend '() '(tuna)) => #f 342 | 343 | (multirember-co 'tuna '(wahoo tuna) a-friend) 344 | ;; eval steps 345 | ;; 1. eq? wahoo tuna => false 346 | ;; 2. (multirember-co 'tuna '(tuna) f), f is a new fn 347 | ;; f calls a-friend with 2nd arg unchanged, 348 | ;; and wahoo cons'd to 1st arg 349 | ;; 3. eq? tuna tuna => true 350 | ;; 4. (multirember-co 'tuna '() f), f is a new fn 351 | ;; f is a fn, which calls previous steps fn 352 | ;; 1st arg unchanged, tuna cons'd to second arg 353 | ;; 5. null? lat => true 354 | ;; 6. call fn from previous step, with two empty lists 355 | ;; 356 | ;; end up with something like: 357 | ((lambda (a b) 358 | ((lambda (x y) 359 | (a-friend (cons 'wahoo x) y)) 360 | a (cons 'tuna b))) 361 | '() '()) 362 | 363 | ;; need to revisit this section of ch. 8 364 | ;; explore continuations more 365 | 366 | ;; ch. 9 367 | ;; ..and again, and again.. 368 | 369 | ;; partial fn 370 | (define (keep-looking a c lat) 371 | (cond ((number? c) (keep-looking a (pick c lat) lat)) 372 | (else (eq? a c)))) 373 | 374 | (define (looking a lat) 375 | (keep-looking a (pick 1 lat) lat)) 376 | 377 | ;; given a pair of sexp 378 | ;; first elem of pair must have length 2 379 | ;; second elem of pair can be anything 380 | ;; make a new pair as shown.. strange 381 | (define (shift p) 382 | (build (fst (fst p)) 383 | (build (snd (fst p)) 384 | (snd p)))) 385 | 386 | (equal? (shift '((a b) c)) 387 | '(a (b c))) 388 | (equal? (shift '((a b) (c d))) 389 | '(a (b (c d)))) 390 | 391 | ;; base case here, when arg is atom 392 | ;; or when snd of arg is atom, and 393 | ;; fst is not a pair.. wierd 394 | (define (align pora) 395 | (cond ((atom? pora) pora) 396 | ((a-pair? (fst pora)) 397 | (align (shift pora))) 398 | (else (build (fst pora) 399 | (align (snd pora)))))) 400 | 401 | (align '((a b) (c d))) 402 | 403 | (define (length* l) 404 | (cond ((null? l) 0) 405 | ((atom? (car l)) (+ 1 (length* (cdr l)))) 406 | (else (+ (length* (car l)) 407 | (length* (cdr l)))))) 408 | 409 | (eq? 6 (length* '((a b (f g)) (c d)))) 410 | 411 | ;; implement length without define 412 | ;; yikes ok re-read 413 | 414 | (define (eternity x) 415 | (eternity x)) 416 | 417 | (define (add1 n) (+ 1 n)) 418 | 419 | ((lambda (length) 420 | (lambda (l) 421 | (cond ((null? l) 0) 422 | (else (add1 (length (cdr l))))))) 423 | eternity) 424 | 425 | ;; through fn app name mk-length 426 | ;; and also name length thru app 427 | (define l0 ; l0 is the result of applying 1st lambda to 2nd lambda 428 | ((lambda (mk-length) ; 1st lambda takes a fn and calls it w/eternity 429 | (mk-length eternity)) 430 | (lambda (length) ; given arg (eternity), return lambda 431 | (lambda (l) ; the lambda we return takes the lat we will 432 | (cond ((null? l) 0) ; measure length of 433 | (else (add1 (length (cdr l))))))))) 434 | 435 | (l0 '()) ; => 0 (holy moly works! for empty list only lol) 436 | 437 | (((lambda (mk-length) 438 | (mk-length 439 | (mk-length 440 | (mk-length 441 | (mk-length eternity))))) 442 | (lambda (length) 443 | (lambda (l) 444 | (cond ((null? l) 0) 445 | (else (add1 (length (cdr l)))))))) 446 | '(a b c)) 447 | ;; => 3 (woah) 448 | 449 | ;; so what role does eternity have in above forms? 450 | ;; none really, just acts like a bottom value i suppose 451 | 452 | (define l-n 453 | ((lambda (mk-length) 454 | (mk-length mk-length)) 455 | (lambda (mk-length) 456 | (lambda (l) 457 | (cond ((null? l) 0) 458 | (else (add1 ((mk-length eternity) 459 | (cdr l))))))))) 460 | 461 | (l-n '(a)) 462 | 463 | ;; ok we're getting somewhere now, maybe 464 | 465 | ;; ((lambda (mk-length) 466 | ;; (mk-length mk-length)) 467 | ;; (lambda (mk-length) 468 | ;; ((lambda (length) 469 | ;; (lambda (l) 470 | ;; (cond ((null? l) 0) 471 | ;; (else (add1 (length (cdr l))))))) 472 | ;; (mk-length mk-length)))) 473 | 474 | ;; above fails, infinite recur 475 | 476 | (define l-x 477 | ((lambda (le) 478 | ((lambda (mk-length) 479 | (mk-length mk-length)) 480 | (lambda (mk-length) 481 | (le (lambda (x) 482 | ((mk-length mk-length) x)))))) 483 | (lambda (length) 484 | (lambda (l) 485 | (cond ((null? l) 0) 486 | (else (add1 (length (cdr l))))))))) 487 | 488 | (l-x '(a b c d e f g)) ; => 7 (jeesh finally!) 489 | 490 | ;; applicative order y-combinator 491 | (define Y 492 | (lambda (le) 493 | ((lambda (f) 494 | (f f)) 495 | (lambda (f) 496 | (le (lambda (x) 497 | ((f f) x))))))) 498 | 499 | ((Y (lambda (length) 500 | (lambda (l) 501 | (cond ((null? l) 0) 502 | (else (add1 (length (cdr l)))))))) 503 | '(1 2 3 4)) ; => 4 504 | 505 | ;; yikes, that is crazy stuff 506 | 507 | ;; ch. 10 508 | ;; what is the value of all this? 509 | 510 | (define new-entry build) 511 | 512 | (define (lookup-in-entry name entry entry-f) 513 | (lookup-in-entry-help 514 | name (fst entry) (snd entry) entry-f)) 515 | 516 | (define (lookup-in-entry-help name names values entry-f) 517 | (cond ((null? names) (entry-f name)) 518 | ((eq? (car names) name) (car values)) 519 | (else (lookup-in-entry-help 520 | name (cdr names) (cdr values) entry-f)))) 521 | 522 | (define extend-table cons) 523 | 524 | (define (lookup-in-table name table table-f) 525 | (cond ((null? table) (table-f name)) 526 | (else (lookup-in-entry 527 | name (car table) 528 | (lambda (n) 529 | (lookup-in-table n (cdr table) table-f)))))) 530 | 531 | (define (expression-to-action e) 532 | (cond ((atom? e) (atom-to-action e)) 533 | (else (list-to-action e)))) 534 | 535 | (define (atom-to-action e) 536 | (cond ((number? e) *const) 537 | ((eq? e #t) *const) 538 | ((eq? e #f) *const) 539 | ((eq? e 'cons) *const) 540 | ((eq? e 'car) *const) 541 | ((eq? e 'cdr) *const) 542 | ((eq? e 'null?) *const) 543 | ((eq? e 'eq?) *const) 544 | ((eq? e 'atom?) *const) 545 | ((eq? e 'zero?) *const) 546 | ((eq? e 'add1) *const) 547 | ((eq? e 'sub1) *const) 548 | ((eq? e 'number?) *const) 549 | (else *identifier))) 550 | 551 | (define (list-to-action e) 552 | (cond ((atom? (car e)) 553 | (cond ((eq? (car e) 'quote) 554 | *quote) 555 | ((eq? (car e) 'lambda) 556 | *lambda) 557 | ((eq? (car e) 'cond) 558 | *cond) 559 | (else *application))) 560 | (else *application))) 561 | 562 | (define (value e) 563 | (meaning e '())) 564 | 565 | (define (meaning e table) 566 | ((expression-to-action e) e table)) 567 | 568 | (define (*const e table) 569 | (cond ((number? e) e) 570 | ((eq? e #t) #t) 571 | ((eq? e #f) #f) 572 | (else (build 'primitive e)))) 573 | 574 | (define (*quote e table) 575 | (text-of e)) 576 | 577 | (define text-of snd) 578 | 579 | (define (*identifier e table) 580 | (lookup-in-table e table initial-table)) 581 | 582 | (define (initial-table name) (car '())) ; gen err 583 | 584 | (define (*lambda e table) 585 | (build 'non-primitive (cons table (cdr e)))) 586 | 587 | (meaning '(lambda (x) (cons x y)) '(((y z) ((8) 9)))) 588 | ;; => (non-primitive ( (((y z) ((8) 9))) (x) (cons x y) )) 589 | ;; => (non-primitive ( env formal body )) 590 | 591 | (define table-of fst) 592 | (define formals-of snd) 593 | (define body-of caddr) 594 | 595 | (define (evcon lines table) 596 | (cond ((else? (question-of (car lines))) 597 | (meaning (answer-of (car lines)) table)) 598 | ((meaning (question-of (car lines)) table) 599 | (meaning (answer-of (car lines)) table)) 600 | (else (evcon (cdr lines) table)))) 601 | 602 | (define (else? e) 603 | (and (atom? e) (eq? e 'else))) 604 | 605 | (define question-of fst) 606 | (define answer-of snd) 607 | 608 | (define (*cond e table) 609 | (evcon (cond-lines-of e) table)) 610 | 611 | (define cond-lines-of cdr) 612 | 613 | (define (evlis args table) 614 | (cond ((null? args) '()) 615 | (else (cons (meaning (car args) table) 616 | (evlis (cdr args) table))))) 617 | 618 | (define (*application e table) 619 | (apply1 (meaning (function-of e) table) 620 | (evlis (arguments-of e) table))) 621 | 622 | (define function-of car) 623 | (define arguments-of cdr) 624 | 625 | (define (primitive? l) 626 | (eq? (fst l) 'primitive)) 627 | (define (non-primitive? l) 628 | (eq? (fst l) 'non-primitive)) 629 | 630 | (define (apply1 fun vals) 631 | (cond ((primitive? fun) 632 | (apply-primitive (snd fun) vals)) 633 | ((non-primitive? fun) 634 | (apply-closure (snd fun) vals)))) 635 | 636 | (define (apply-primitive name vals) 637 | (cond 638 | ((eq? name 'cons) 639 | (cons (fst vals) (snd vals))) 640 | ((eq? name 'car) 641 | (car (fst vals))) 642 | ((eq? name 'cdr) 643 | (cdr (fst vals))) 644 | ((eq? name 'null?) 645 | (null? (fst vals))) 646 | ((eq? name 'eq?) 647 | (eq? (fst vals) (snd vals))) 648 | ((eq? name 'atom?) 649 | (:atom? (fst vals))) 650 | ((eq? name 'zero?) 651 | (zero? (fst vals))) 652 | ((eq? name 'add1) 653 | (add1 (fst vals))) 654 | ((eq? name 'sub1) 655 | (sub1 (fst vals))) 656 | ((eq? name 'number?) 657 | (number? (fst vals))))) 658 | 659 | (define (:atom? e) 660 | (cond ((atom? e) #t) 661 | ((null? e) #f) 662 | ((eq? (car e) 'primitive) #t) 663 | ((eq? (car e) 'non-primitive) #t) 664 | (else #f))) 665 | 666 | ;; how to find value of (f a b)? 667 | ;; f is (lambda (x y) (cons x y)) 668 | ;; a=1, b=(2) 669 | 670 | ;; add formals to env and substitute fn body? 671 | 672 | (define (apply-closure closure vals) 673 | (meaning (body-of closure) 674 | (extend-table 675 | (new-entry (formals-of closure) vals) 676 | (table-of closure)))) 677 | 678 | ;; test apply closure 679 | ;; 680 | 681 | (define a-closure '((((u v w) 682 | (1 2 3)) 683 | ((x y z) 684 | (4 5 6))) 685 | (x y) 686 | (cons z x))) 687 | 688 | (define a-vals '((a b c) (d e f))) 689 | 690 | ;; test this guy 691 | (apply-closure a-closure a-vals) 692 | 693 | (body-of a-closure) ; => (cons z x) 694 | (table-of a-closure) ; => (((u v w) (1 2 3)) ((x y z) (4 5 6))) 695 | (formals-of a-closure) ; => (x y) 696 | 697 | (define a-tbl (extend-table (new-entry (formals-of a-closure) a-vals) (table-of a-closure))) 698 | ;; => (((x y) ((a b c) (d e f))) ((u v w) (1 2 3)) ((x y z) (4 5 6))) 699 | 700 | (expression-to-action '(cons z x)) 701 | (meaning (function-of '(cons z x)) a-tbl) 702 | (expression-to-action '(z x)) ; => *application 703 | 704 | ;; follow 705 | (meaning '(cons z x) a-tbl) 706 | (evlis '(z x) a-tbl) ; => (6 (a b c)) 707 | (meaning 'cons a-tbl) ; => (primitive cons) 708 | 709 | (apply1 '(primitive cons) '(6 (a b c))) 710 | 711 | ;; (define (*application e table) 712 | ;; (apply1 (meaning (function-of e) table) 713 | ;; (meaning (arguments-of e) table))) 714 | ;; (define (meaning e table) 715 | ;; ((expression-to-action e) e table)) 716 | 717 | ;; scratch tests 718 | (define eg0 (new-entry '(a b c d) '(10 11 12 13))) 719 | (define eg1 (new-entry '(w x y z) '(100 101 102 103))) 720 | (define tbl0 (extend-table eg1 (extend-table eg0 '()))) 721 | (lookup-in-entry 'b eg0 (lambda (n) n)) 722 | (lookup-in-table 'x tbl0 (lambda (n) (display n))) 723 | (*cond '(cond (coffee klatsch) (else party)) 724 | '(((coffee) (#t)) ((klatsch party) (5 (6))))) 725 | 726 | ;; play w/interpreter 727 | ;; 728 | 729 | ;; primitive application 730 | (value '(cons 6 (quote (a b c)))) 731 | 732 | ;; non-primitive 733 | (value '((lambda (x y) 734 | (cons x y)) 735 | 9 (quote (d e f)))) 736 | 737 | ;; restart mit-scheme 738 | (restart 1) 739 | -------------------------------------------------------------------------------- /src/test-manager/doc/testing.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | test-manager/ - An automatic unit-testing framework for MIT Scheme 6 | 7 | 8 | 9 | 10 | 11 | 12 |

13 | 14 | 15 | 34 | 35 | 36 |
37 |

38 |

39 |
40 |

NAME

41 |

test-manager/ - An automatic unit-testing framework for MIT Scheme

42 |

43 |

44 |
45 |

SYNOPSYS

46 | 
 47 |   (load "test-manager/load.scm")
48 | 
 49 |   ; This is a test group named simple-stuff
 50 |   (in-test-group
 51 |    simple-stuff
52 | 
 53 |    ; This is one test named arithmetic
 54 |    (define-test (arithmetic)
 55 |      "Checking that set! and arithmetic work"
 56 |      (define foo 5)
 57 |      (check (= 5 foo) "Foo should start as five.")
 58 |      (set! foo 6)
 59 |      (check (= 36 (* foo foo))))
60 | 
 61 |    ; Each of these will become a separate anonymous one-form test
 62 |    (define-each-test
 63 |      (check (= 4 (+ 2 2)) "Two and two should make four.")
 64 |      (check (= 2147483648 (+ 2147483647 1)) "Addition shouldn't overflow."))
65 | 
 66 |    ; Each of these will become a separate anonymous one-form test using check
 67 |    (define-each-check
 68 |      (= 6 (+ 2 2 2))
 69 |      (equal? '(1 2 3) (cons 1 '(2 3))))
70 | 
 71 |    ; This is a test that looks like a REPL interaction
 72 |    (define-test (interactive)
 73 |      (interaction
 74 |       (define foo 5)
 75 |       foo
 76 |       (produces 5)  ; This compares against the value of the last form
 77 |       (set! foo 6)
 78 |       (* foo foo)
 79 |       (produces 36))))
80 | 
 81 |   (run-registered-tests)
82 | 
 83 |   ; Can run individual groups or tests with
 84 |   (run-test '(simple-stuff))
 85 |   (run-test '(simple-stuff arithmetic))
86 |

87 |

88 |
89 |

DESCRIPTION

90 |

This test framework defines a language for specifying test suites and 91 | a simple set of commands for running them. A test suite is a 92 | collection of individual tests grouped into a hierarchy of test 93 | groups. The test group hierarchy serves to semantically aggregate the 94 | tests, allowing the definition of shared code for set up, tear down, 95 | and surround, and also partition the test namespace to avoid 96 | collisions.

97 |

The individual tests are ordinary procedures, with some associated 98 | bookkeeping. A test is considered to pass if it returns normally, 99 | and to fail if it raises some condition that it does not handle 100 | (tests escaping into continuations leads to unspecified behavior).

101 |

The framework provides a check macro and a library of assertion 102 | procedures that can be invoked in tests and have the desired behavior 103 | of raising an appropriate condition if they fail. The framework also 104 | provides an interaction macro, together with a produces 105 | procedure, for simulating read-eval-print interactions, and an 106 | extensible pattern-matching facility for easier testing of the 107 | relevant aspects of a result while ignoring the irrelevant ones.

108 |

109 |

110 |

Defining Test Suites

111 |

All tests are grouped into a hierarchy of test groups. 112 | At any point in the definition of a test suite, there is an implicit 113 | ``current test group'', into which tests and subgroups can be added. By 114 | default, the current test group is the top-level test group, which is 115 | the root of the test group hierarchy.

116 |
117 |
(define-test (name) expression ... )
118 | 119 |
120 |

Define a test named name that consists of the given expressions, 121 | and add it to the current test group. When the test is run, the 122 | expressions will be executed in order, just like the body of any 123 | procedure. If the test raises any condition that it does not handle, 124 | it is considered to have failed. If it returns normally, it is 125 | considered to have passed. Usually, tests will contain uses of the 126 | check macro or of assertions from the list below, which raise 127 | appropriate conditions when they fail. In the spirit of Lisp 128 | docstrings, if the first expression in the test body is a literal 129 | string, that string will be included in the failure report if the test 130 | should fail.

131 |

This is the most verbose and most expressive test definition syntax. 132 | The four test definition syntaxes provided below are increasingly 133 | terse syntactic sugar for common usage patterns of this syntax.

134 |
135 |
(define-test () expression ... )
136 | 137 |
138 |

Define an explicitly anonymous test. I can't see why you would want 139 | to do this, but it is provided for completeness.

140 |
141 |
(define-test expression)
142 | 143 |
144 |

Define a one-expression anonymous test. The single expression will be 145 | printed in the failure report if the test fails. This is a special 146 | case of define-each-test, below.

147 |
148 |
(define-each-test expression ... )
149 | 150 |
151 |

Define a one-expression anonymous test for each of the given 152 | expressions. If any of the tests fail, the corresponding expression 153 | will be printed in that test's failure report.

154 |
155 |
(define-each-check expression ...)
156 | 157 |
158 |

Define a one-expression anonymous test for each of the given 159 | expressions by wrapping it in a use of the check macro, below.

160 |

If you have many simple independent checks you need to make and 161 | you don't want to invent names for each individual one, this is the 162 | test definition syntax for you.

163 |
164 |
(in-test-group name expression ... )
165 | 166 |
167 |

Locate (or create) a test subgroup called name in the current test 168 | group. Then temporarily make this subgroup the current test group, 169 | and execute the expressions in the body of in-test-group. This 170 | groups any tests and further subgroups defined by those expressions 171 | into this test group. Test groups can nest arbitrarily deep. Test 172 | groups serve to disambiguate the names of tests, and to group them 173 | semantically. In particular, should a test fail, the names of the 174 | stack of groups it's in will be displayed along with the test name 175 | itself.

176 |
177 |
(define-set-up expression ...)
178 | 179 |
180 |

Defines a sequence of expressions to be run before every test in 181 | the current test group. Clobbers any previously defined set up 182 | for this group.

183 |
184 |
(define-tear-down expression ...)
185 | 186 |
187 |

Defines a sequence of expressions to be run after every test in 188 | the current test group. Clobbers any previously defined tear down 189 | for this group.

190 |
191 |
(define-surround expression ...)
192 | 193 |
194 |

Defines a sequence of expressions to be run surrounding every test in 195 | the current test group. Inside the define-surround, the identifier 196 | run-test is bound to a nullary procedure that actually runs the 197 | test. The test will get run as many times as you call run-test, so 198 | you can run each test under several conditions (or accidentally not 199 | run it at all if you forget to call run-test). Clobbers any 200 | previously defined surround for this group.

201 |
202 |
(define-group-set-up expression ...)
203 | 204 |
205 |

Defines a sequence of expressions to be run once before running any 206 | test in the current test group. Clobbers any previously defined group 207 | set up for this group.

208 |
209 |
(define-group-tear-down expression ...)
210 | 211 |
212 |

Defines a sequence of expressions to be run once after running all 213 | tests in the current test group. Clobbers any previously defined 214 | group tear down for this group.

215 |
216 |
(define-group-surround expression ...)
217 | 218 |
219 |

Defines a sequence of expressions to be run once surrounding running 220 | the tests in the current test group. Inside the 221 | define-group-surround, the identifier run-test is bound to a 222 | nullary procedure that actually runs the tests in this group. 223 | Clobbers any previously defined group surround for this group.

224 |
225 |
226 |

227 |

228 |

Running Test Suites

229 |

The following procedures are provided for running test suites:

230 |
231 |
(run-test name-stack)
232 | 233 |
234 |

Looks up the test indicated by name-stack in the current test group, 235 | runs it, and prints a report of the results. Returns the number of 236 | tests that did not pass. An empty list for a name stack indicates the 237 | whole group, a singleton list indicates that immediate descendant, a 238 | two-element list indicates a descendant of a descendant, etc. For 239 | example, (run-test '(simple-stuff arithmetic)) would run the first 240 | test defined in the example at the top of this page.

241 |
242 |
(run-registered-tests)
243 | 244 |
245 |

Runs all tests registered so far, and prints a report of the results. 246 | Returns the number of tests that did not pass. This could have been 247 | defined as (run-test '()).

248 |
249 |
(clear-registered-tests!)
250 | 251 |
252 |

Unregister all tests. Useful when loading and reloading test suites 253 | interactively. For more elaborate test structure manipulation 254 | facilities, see also test-group.scm.

255 |
256 |
257 |

258 |

259 |

Checks

260 |

The check macro is the main mechanism for asking tests to actually 261 | test something:

262 |
263 |
(check expression [message])
264 | 265 |
266 |

Executes the expression, and passes iff that expression returns a true 267 | value (to wit, not #f). If the expression returns #f, constructs a 268 | failure report from the expression, the message if any, and the values 269 | of the immediate subexpressions of the expression.

270 |
271 |
272 |

check is a macro so that it can examine the expression provided and 273 | construct a useful failure report if the expression does not return a 274 | true value. Specifically, the failure report includes the expression 275 | itself, as well as the values that all subexpressions (except the 276 | first) of that expression evaluated to. For example,

277 | 
278 |  (check (< (+ 2 5) (* 3 2)))
279 |

fails and reports

280 | 
281 |  Form      : (< (+ 2 5) (* 3 2))
282 |  Arg values: (7 6)
283 |

so you can see right away both what failed, and, to some degree, what 284 | the problem was.

285 |

In the event that the failure report generated by check itself is 286 | inadequate, check also accepts an optional second argument that is 287 | interpreted as a user-supplied message to be added to the failure 288 | report. The message can be either a string, or an arbitrary object 289 | that will be coerced to a string by display, or a promise (as 290 | created by delay), which will be forced and the result coerced to a 291 | string. The latter is useful for checks with dynamically computed 292 | messages, because that computation will then only be performed if the 293 | test actually fails, and in general for doing some computation at 294 | check failure time.

295 |

296 |

297 |

Interactions

298 |

The style of interactively fooling with a piece of code at the 299 | read-eval-print loop differs from the style of writing units tests for 300 | a piece of code and running them. One notable difference is that at 301 | the REPL you write some expression and examine its return value to see 302 | whether it was what you expected, whereas when writing a unit test you 303 | write a check form that contains both the expression under test and 304 | the criterion you expect it to satisfy. In order to decrease the 305 | impedance mismatch between these two ways of verifying what a program 306 | does, test-manager provides the procedure produces, which 307 | retroactively checks the last return value, and the macro 308 | interaction, which enables produces to work inside a unit test.

309 |
310 |
(produces pattern)
311 | 312 |
313 |

Checks that the return value of the previous evaluated expression 314 | matches (via generic-match, below) the provided pattern. This 315 | works at the REPL via the REPL history, and also works inside a use of 316 | the interaction macro.

317 |
318 |
(interation form ...)
319 | 320 |
321 |

Tracks the return values of each form and makes them available for 322 | use with produces. For an example, see the last test in the 323 | synopsis.

324 |
325 |
326 |

327 |

328 |

Pattern Matching

329 |

The user-extensible pattern matching facility is the generic procedure 330 | generic-match. This procedure is generic in the sense of the 331 | Scheme Object System provided with MIT Scheme. It can be used in 332 | tests directly, and is automatically invoked by produces above, and 333 | assert-match and assert-no-match below.

334 |
335 |
(generic-match pattern object)
336 | 337 |
338 |

Returns #t iff the given object matches the given pattern. The 339 | meaning of ``matches'' is user-extensible by adding methods to this 340 | generic procedure. By default compares whether the pattern is 341 | equal? to the object, but also see provided methods below.

342 |
343 |
(generic-match pattern-string string)
344 | 345 |
346 |

If the pattern and the object are strings, interprets the pattern 347 | as a regular expression and matches it against the object.

348 |
349 |
(generic-match pattern-pair pair)
350 | 351 |
352 |

If the pattern and the object are pairs, recursively matches their 353 | cars and cdrs against each other.

354 |
355 |
(generic-match pattern-vector vector)
356 | 357 |
358 |

If the pattern and the object are vectors, recursively matches their 359 | components against each other elementwise.

360 |
361 |
(generic-match x y)
362 | 363 |
364 |

If the pattern and the object are inexact numbers, checks them for 365 | equality, and then then checks whether the object rounded to five 366 | significant digits equals the pattern. For example, (generic-match 367 | 1.4142 (sqrt 2)) returns #t, as does 368 | (generic-match 1.4142135623730951 (sqrt 2)).

369 |
370 |
371 |

372 |

373 |

Assertions

374 |

The following assertion procedures are provided for situations where 375 | check being a macro makes it unweildy. The message arguments to 376 | the assertions are user-specified messages to print to the output if 377 | the given assertion fails. The assert-proc assertion requires a 378 | message argument because it cannot construct a useful output without 379 | one, and because it is not really meant for extensive direct use. The 380 | message is optional for the other assertions because they can say 381 | something at least mildly informative even without a user-supplied 382 | message. In any case, the message arguments are treated the same way 383 | as by check.

384 |
385 |
(assert-proc message proc)
386 | 387 |
388 |

Passes iff the given procedure, invoked with no arguments, returns a 389 | true value. On failure, arranges for the given message to appear in 390 | the failure report. This is a primitive assertion in whose terms 391 | other assertions are defined.

392 |
393 |
(assert-true thing [message])
394 | 395 |
396 |

Passes iff the given value is a true value (to wit, not #f).

397 |
398 |
(assert-false thing [message])
399 | 400 |
401 |

Passes iff the given value is a false value (to wit, #f).

402 |
403 |
(assert-equal expected actual [message]) 404 | Likewise assert-eqv, assert-eq, and assert-=
405 | 406 |
407 |

Passes iff the given actual value is equivalent, according to the 408 | corresponding predicate, to the expected value. Produces a 409 | reasonably helpful message on failure, and includes the optional 410 | message argument in it if present. When in doubt, use 411 | assert-equal to compare most things; use assert-= to compare 412 | exact numbers like integers; and use assert-in-delta, below, for 413 | inexact numbers like floating points.

414 |
415 |
assert-equals, assert=
416 | 417 |
418 |

Are aliases for assert-equal and assert-=, respectively.

419 |
420 |
(assert-equivalent predicate [pred-name])
421 | 422 |
423 |

This is intended as a tool for building custom assertions. Returns an 424 | assertion procedure that compares an expected and an actual value with 425 | the given predicate and produces a reasonable failure message. 426 | assert-equal and company could have been defined in terms of 427 | assert-equivalent as, for example, (define assert-equal 428 | (assert-equivalent equal? "equal?")).

429 |
430 |
assert-< assert-> assert-<= assert->=
431 | 432 |
433 |

Like assert-=, but with a different comparator. In particular, these 434 | aren't equivalence relations, so the order of arguments matters.

435 |
436 |
(assert-matches pattern object [message])
437 | 438 |
439 |

Passes iff the given object matches the given pattern, per 440 | generic-match.

441 |
442 |
(assert-no-match pattern object [message])
443 | 444 |
445 |

Passes iff the given object does not match the given pattern, likewise 446 | per generic-match.

447 |
448 |
(assert-in-delta expected actual delta [message])
449 | 450 |
451 |

Passes iff the given actual value differs, in absolute value, from 452 | the given expected value by no more than delta. Use this in 453 | preference to assert-= to check sameness of inexact numerical 454 | values.

455 |
456 |
457 |

458 |

459 |
460 |

PORTABILITY

461 |

I originally started this project with MIT Scheme and Guile in mind as 462 | target Scheme implementations. That aim met with success through 463 | version 1.1, but as of version 1.2 I dropped explicit support for the 464 | Guile port. I have left all the portability code intact; the vast 465 | majority of the documented features should work in Guile. Also, since 466 | this software has been two-Scheme for much of its life, I expect it 467 | should not be hard to port to other Schemes.

468 |

The specific things that I know do not work in Guile are: produces 469 | does not work in the Guile REPL (though it does still work inside 470 | interaction) which rather defeats its purpose; generic-match is 471 | not actually a generic procedure in Guile (though that could 472 | presumably be fixed by one who knew Guile's generic procedure 473 | facilities); and check does not accept a message argument in Guile.

474 |

475 |

476 |
477 |

BUGS

478 |

This unit testing framework is a work in progress. The test groups do 479 | not support as much shared set up code among their tests as I would 480 | like, and the language for explicit test group handling is 481 | ill-specified and undocumented (peruse test-group.scm if interested). 482 | Suggestions are welcome.

483 |

484 |

485 |
486 |

AUTHOR

487 |

Alexey Radul, axch@mit.edu

488 | 489 | 490 | 491 | 492 | --------------------------------------------------------------------------------