Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 118 lines (92 sloc) 3.816 kb
e89c999 @davegurnell Initialised repository.
davegurnell authored
1 #lang scheme/base
2
3 (require "debug.ss"
4 "test-base.ss")
5
6 ; Helpers ----------------------------------------
7
8 (define-syntax capture-output
9 (syntax-rules ()
10 [(_ expr ...)
11 (let ([out (open-output-string)])
12 (parameterize ([current-output-port out])
13 expr ... (get-output-string out)))]))
14
15 (define-syntax discard-output
16 (syntax-rules ()
17 [(_ expr ...)
18 (let ([out (open-output-string)])
19 (parameterize ([current-output-port out])
20 expr ...))]))
21
22 ; Test suite -----------------------------------
23
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
24 (define/provide-test-suite debug-tests
25
26 (test-equal? "debug : passes value transparently"
27 (discard-output (debug "Message" (+ 1 2 3)))
28 6)
29
30 (test-equal? "debug : prints value"
31 (capture-output (debug "Message" (+ 1 2 3)))
32 "Message:\n 6\n")
33
34 (test-equal? "debug* : passes value transparently"
35 (discard-output (debug* "Message" + 1 2 3))
36 6)
37
38 (test-equal? "debug* : prints value"
39 (capture-output (debug* "Message" + 1 2 3))
40 "Message:\n 6\n")
41
42 (test-equal? "debug-location : prints value"
43 (capture-output (debug-location))
44 "Reached debug-test.ss:43:20\n")
45
46 (test-equal? "debug-location : prints value and expression"
47 (capture-output (debug-location (+ 1 2 3)))
48 "Reached debug-test.ss:47:20:\n 6\n")
49
50 (test-equal? "debug-enabled?"
51 (parameterize ([debug-enabled? #f])
52 (capture-output (debug "Message" (+ 1 2 3))))
53 "")
54
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
55 (test-equal? "define/debug"
56 (capture-output (define/debug a 2) (void))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
57 "a:\n 2\n")
58
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
59 (test-equal? "define-values/debug"
60 (capture-output (define-values/debug (a b) (values 1 2)) (void))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
61 "(a b):\n (1 2)\n")
62
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
63 (test-equal? "let/debug"
64 (capture-output (let/debug ([a 1] [b 2])
65 (+ a b)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
66 "a:\n 1\nb:\n 2\n")
67
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
68
69 (test-equal? "let/debug : let loop"
70 (capture-output (let/debug loop ([a 1])
71 (unless (= a 3)
72 (loop (add1 a)))))
73 "a:\n 1\na:\n 2\na:\n 3\n")
74
75 (test-equal? "let*/debug"
76 (capture-output (let*/debug ([a 1] [b (+ a 2)])
77 (+ a b)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
78 "a:\n 1\nb:\n 3\n")
79
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
80 (test-equal? "letrec/debug"
81 (capture-output (letrec/debug ([a 1] [b 2] [c 3])
82 (+ a b c)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
83 "a:\n 1\nb:\n 2\nc:\n 3\n")
84
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
85 (test-equal? "let-values/debug"
86 (capture-output (let-values/debug ([(a b c) (values 1 2 3)]
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
87 [(d e f) (values (+ 4 5) (+ 6 7) (+ 8 9))])
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
88 (+ a b c d e f)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
89 "(a b c):\n (1 2 3)\n(d e f):\n (9 13 17)\n")
90
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
91 (test-equal? "let*-values/debug"
92 (capture-output (let*-values/debug ([(a b) (values 1 2)]
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
93 [(c d) (values (+ a b) (- a b))])
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
94 (+ a b c d)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
95 "(a b):\n (1 2)\n(c d):\n (3 -1)\n")
96
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
97 (test-equal? "letrec-values/debug"
98 (capture-output (letrec-values/debug ([(a b) (values 1 2)]
e89c999 @davegurnell Initialised repository.
davegurnell authored
99 [(c d) (values (+ a b) (- a b))])
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
100 (+ a b c d)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
101 "(a b):\n (1 2)\n(c d):\n (3 -1)\n")
102
103 (test-case "with-pretty-indent"
104 (parameterize ([pretty-print-columns 6])
105 (check-equal? (pretty-format (list 1 2 3 4 5))
106 "(1\n 2\n 3\n 4\n 5)")
107 (check-equal? (with-pretty-indent "=="
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
108 (pretty-format (list 1 2 3 4 5)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
109 "==(1\n== 2\n== 3\n== 4\n== 5)")
110 (check-equal? (with-pretty-indent "==="
fbb6b45 @davegurnell Added tests and patch for "let loop" form of let/debug.
davegurnell authored
111 (pretty-format (list 1 2 3 4 5)))
0b6e9b5 @davegurnell Properly fixed bug in eq? and equal? in match.ss.
davegurnell authored
112 "===(1\n=== 2\n=== 3\n=== 4\n=== 5)")))
113
114 (test-case "exn-context"
115 (let ([ctxt (exn-context (make-exn "Test" (current-continuation-marks)))])
116 (check-pred list? ctxt)
117 (check-true (andmap symbol? ctxt)))))
Something went wrong with that request. Please try again.