source: trunk/source/tests/ansi-tests/trace.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Dec 12 19:53:11 2004
4;;;; Contains: Tests of TRACE, UNTRACE
5
6(in-package :cl-test)
7
8(defun function-to-trace (x) (car x))
9(defun another-function-to-trace (x) (cdr x))
10(defun (setf function-to-trace) (val arg) (setf (car arg) val))
11
12(declaim (notinline function-to-trace
13                    another-function-to-trace
14                    (setf function-to-trace)))
15
16(deftest trace.1
17  (progn
18    (untrace)  ;; ensure it's not traced
19    (with-output-to-string
20      (*trace-output*)
21      (assert (eql (function-to-trace '(a)) 'a))))
22  "")
23
24(deftest trace.2
25  (progn
26    (trace function-to-trace)
27    (equal "" (with-output-to-string
28                (*trace-output*)
29                (assert (eql (function-to-trace '(b)) 'b)))))
30  nil)
31
32(deftest trace.3
33  (progn
34    (untrace)
35    (trace function-to-trace)
36    (prog1 (trace)
37      (untrace)
38      (assert (null (trace)))))
39  (function-to-trace))
40
41
42(deftest trace.4
43  (progn
44    (untrace)
45    (trace function-to-trace)
46    (handler-bind ((warning #'muffle-warning))
47                  (trace function-to-trace))
48    (prog1 (trace)
49      (untrace)
50      (assert (null (trace)))))
51  (function-to-trace))
52
53(deftest trace.5
54  (progn
55    (untrace)
56    (trace (setf function-to-trace))
57    (prog1 (trace)
58      (untrace)
59      (assert (null (trace)))))
60  ((setf function-to-trace)))
61
62(deftest trace.6
63  (progn
64    (untrace)
65    (trace (setf function-to-trace))
66    (handler-bind ((warning #'muffle-warning))
67                  (trace (setf function-to-trace)))
68    (prog1 (trace)
69      (untrace)
70      (assert (null (trace)))))
71  ((setf function-to-trace)))
72
73(deftest trace.7
74  (progn
75    (untrace)
76    (with-output-to-string
77      (*trace-output*)
78      (let ((x (list nil)))
79        (assert (eql (setf (function-to-trace x) 'a) 'a))
80        (assert (equal x '(a))))))
81  "")
82
83(deftest trace.8
84  (progn
85    (untrace)
86    (trace (setf function-to-trace))
87    (equal ""
88           (with-output-to-string
89             (*trace-output*)
90             (let ((x (list nil)))
91               (assert (eql (setf (function-to-trace x) 'a) 'a))
92               (assert (equal x '(a)))))))
93  nil)
94
95(deftest trace.9
96  (progn
97    (untrace)
98    (trace function-to-trace another-function-to-trace)
99    (assert (not (equal "" (with-output-to-string
100                             (*trace-output*)
101                             (assert (eql (function-to-trace '(b)) 'b))))))
102    (assert (not (equal "" (with-output-to-string
103                             (*trace-output*)
104                             (assert (eql (another-function-to-trace '(c . d))
105                                          'd))))))
106    (prog1
107        (sort (copy-list (trace))
108              #'(lambda (k1 k2) (string< (symbol-name k1)
109                                         (symbol-name k2))))
110      (untrace)))
111  (another-function-to-trace function-to-trace))
112
113(deftest trace.10
114  (progn
115    (untrace)
116    (assert (null (trace)))
117    (trace function-to-trace)
118    (untrace function-to-trace)
119    (assert (null (trace)))
120    (handler-bind ((warning #'muffle-warning)) (untrace function-to-trace))
121    (assert (null (trace)))
122    nil)
123  nil)
124
125(deftest trace.11
126  (progn
127    (untrace)
128    (trace function-to-trace another-function-to-trace)
129    (untrace function-to-trace another-function-to-trace)
130    (trace))
131  nil)
132
133;;; Tracing a generic function
134
135(declaim (notinline generic-function-to-trace))
136
137(deftest trace.12
138  (progn
139    (untrace)
140    (eval '(defgeneric generic-function-to-trace (x y)))
141    (trace generic-function-to-trace)
142    (prog1 (trace) (untrace)))
143  (generic-function-to-trace))
144
145(deftest trace.13
146  (progn
147    (untrace)
148    (eval '(defgeneric generic-function-to-trace (x y)))
149    (trace generic-function-to-trace)
150    (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil))
151    (prog1 (trace) (untrace)))
152  (generic-function-to-trace))
153
154(deftest trace.14
155  (progn
156    (untrace)
157    (eval '(defgeneric generic-function-to-trace (x y)))
158    (trace generic-function-to-trace)
159    (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil))
160    (assert (not (equal (with-output-to-string
161                          (*trace-output*)
162                          (assert (null (generic-function-to-trace 'a 'b))))
163                        "")))
164    (prog1
165        (trace)
166      (untrace generic-function-to-trace)
167      (assert (null (trace)))))
168  (generic-function-to-trace))
169
170(declaim (notinline generic-function-to-trace2))
171
172(deftest trace.15
173  (progn
174    (untrace)
175    (let* ((gf (eval '(defgeneric generic-function-to-trace2 (x y))))
176           (m (eval '(defmethod generic-function-to-trace2
177                       ((x integer)(y integer))
178                       :foo))))
179      (eval '(defmethod generic-function-to-trace2
180               ((x symbol)(y symbol)) :bar))
181      (assert (eql (generic-function-to-trace2 1 2) :foo))
182      (assert (eql (generic-function-to-trace2 'a 'b) :bar))
183      (trace generic-function-to-trace2)
184      (assert (equal (trace) '(generic-function-to-trace2)))
185      (remove-method gf m)
186      (prog1 (trace) (untrace))))
187  (generic-function-to-trace2))
Note: See TracBrowser for help on using the repository browser.