31cb5171528a5ac599b66cd6dcd2824a031e4da0
[sbcl.git] / interface.impure.lisp
1 ;;;; tests for problems in the interface presented to the user/programmer
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; from CMU CL.
9 ;;;;
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
13
14 (load "assertoid.lisp")
15 (load "test-util.lisp")
16 (use-package "ASSERTOID")
17 (use-package "TEST-UTIL")
18
19 (defun (setf foo) (x)
20   "(setf foo) documentation"
21   x)
22
23 (assert (string= (documentation '(setf foo) 'function)
24                  "(setf foo) documentation"))
25 (assert (string= (documentation #'(setf foo) 'function)
26                  "(setf foo) documentation"))
27
28 (assert (string= (documentation '(setf foo) 'function)
29                  "(setf foo) documentation"))
30 (assert (string= (documentation #'(setf foo) 'function)
31                  "(setf foo) documentation"))
32 \f
33 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
34 (defun disassemble-fun (x) x)
35 (disassemble 'disassemble-fun)
36
37 (let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
38 (disassemble 'disassemble-closure)
39
40 #+sb-eval
41 (progn
42   ;; Nor should it fail on interpreted functions
43   (let ((sb-ext:*evaluator-mode* :interpret))
44     (eval `(defun disassemble-eval (x) x))
45     (disassemble 'disassemble-eval))
46
47   ;; disassemble-eval should still be an interpreted function.
48   ;; clhs disassemble: "(If that function is an interpreted function,
49   ;; it is first compiled but the result of this implicit compilation
50   ;; is not installed.)"
51   (assert (sb-eval:interpreted-function-p #'disassemble-eval)))
52
53 ;; nor should it fail on generic functions or other funcallable instances
54 (defgeneric disassemble-generic (x))
55 (disassemble 'disassemble-generic)
56 (let ((fin (sb-mop:make-instance 'sb-mop:funcallable-standard-object)))
57   (disassemble fin))
58
59 ;;; while we're at it, much the same applies to
60 ;;; FUNCTION-LAMBDA-EXPRESSION:
61 (defun fle-fun (x) x)
62 (function-lambda-expression #'fle-fun)
63
64 (let ((x 1)) (defun fle-closure (y) (if y (setq x y) x)))
65 (function-lambda-expression #'fle-closure)
66
67 #+sb-eval
68 (progn
69   ;; Nor should it fail on interpreted functions
70   (let ((sb-ext:*evaluator-mode* :interpret))
71     (eval `(defun fle-eval (x) x))
72     (function-lambda-expression #'fle-eval))
73
74   ;; fle-eval should still be an interpreted function.
75   (assert (sb-eval:interpreted-function-p #'fle-eval)))
76
77 ;; nor should it fail on generic functions or other funcallable instances
78 (defgeneric fle-generic (x))
79 (function-lambda-expression #'fle-generic)
80 (let ((fin (sb-mop:make-instance 'sb-mop:funcallable-standard-object)))
81   (function-lambda-expression fin))
82 \f
83 ;;; support for DESCRIBE tests
84 (defstruct to-be-described a b)
85 (defclass forward-describe-class (forward-describe-ref) (a))
86 (let ((sb-ext:*evaluator-mode* :compile))
87   (eval `(let (x) (defun closure-to-describe () (incf x)))))
88
89 ;;; DESCRIBE should run without signalling an error.
90 (with-test (:name (describe :no-error))
91   (describe (make-to-be-described))
92   (describe 12)
93   (describe "a string")
94   (describe 'symbolism)
95   (describe (find-package :cl))
96   (describe '(a list))
97   (describe #(a vector))
98 ;; bug 824974
99   (describe 'closure-to-describe))
100
101 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
102 ;;; FRESH-LINE and TERPRI neatly.
103 (dolist (i (list (make-to-be-described :a 14) 12 "a string"
104                  #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword
105                  (find-package :keyword) (list 1 2 3)
106                  nil (cons 1 2) (make-hash-table)
107                  (let ((h (make-hash-table)))
108                    (setf (gethash 10 h) 100
109                          (gethash 11 h) 121)
110                    h)
111                  (make-condition 'simple-error)
112                  (make-condition 'simple-error :format-control "fc")
113                  #'car #'make-to-be-described (lambda (x) (+ x 11))
114                  (constantly 'foo) #'(setf to-be-described-a)
115                  #'describe-object (find-class 'to-be-described)
116                  (find-class 'forward-describe-class)
117                  (find-class 'forward-describe-ref) (find-class 'cons)))
118   (let ((s (with-output-to-string (s)
119              (write-char #\x s)
120              (describe i s))))
121     (macrolet ((check (form)
122                  `(or ,form
123                       (error "misbehavior in DESCRIBE of ~S:~%   ~S" i ',form))))
124       (check (char= #\x (char s 0)))
125       ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
126       (check (char= #\newline (char s 1)))
127       (check (char/= #\newline (char s 2)))
128       ;; one trailing #\NEWLINE from TERPRI or the like, no more
129       (let ((n (length s)))
130         (check (char= #\newline (char s (- n 1))))
131         (check (char/= #\newline (char s (- n 2))))))))
132
133 \f
134 ;;; Tests of documentation on types and classes
135 (defclass foo ()
136   ()
137   (:documentation "FOO"))
138 (defstruct bar "BAR")
139 (define-condition baz ()
140   ()
141   (:documentation "BAZ"))
142 (deftype quux ()
143   "QUUX"
144   't)
145 (defstruct (frob (:type vector)) "FROB")
146 (macrolet
147     ((do-class (name expected &optional structurep)
148        `(progn
149          (assert (string= (documentation ',name 'type) ,expected))
150          (assert (string= (documentation (find-class ',name) 'type) ,expected))
151          (assert (string= (documentation (find-class ',name) 't) ,expected))
152          ,@(when structurep
153             `((assert (string= (documentation ',name 'structure) ,expected))))
154          (let ((new1 (symbol-name (gensym "NEW1")))
155                (new2 (symbol-name (gensym "NEW2")))
156                (new3 (symbol-name (gensym "NEW3")))
157                (new4 (symbol-name (gensym "NEW4"))))
158            (declare (ignorable new4))
159            (setf (documentation ',name 'type) new1)
160            (assert (string= (documentation (find-class ',name) 'type) new1))
161            (setf (documentation (find-class ',name) 'type) new2)
162            (assert (string= (documentation (find-class ',name) 't) new2))
163            (setf (documentation (find-class ',name) 't) new3)
164            (assert (string= (documentation ',name 'type) new3))
165            ,@(when structurep
166               `((assert (string= (documentation ',name 'structure) new3))
167                 (setf (documentation ',name 'structure) new4)
168                 (assert (string= (documentation ',name 'structure) new4))))))))
169   (do-class foo "FOO")
170   (do-class bar "BAR" t)
171   (do-class baz "BAZ"))
172
173 (assert (string= (documentation 'quux 'type) "QUUX"))
174 (setf (documentation 'quux 'type) "NEW4")
175 (assert (string= (documentation 'quux 'type) "NEW4"))
176
177 (assert (string= (documentation 'frob 'structure) "FROB"))
178 (setf (documentation 'frob 'structure) "NEW5")
179 (assert (string= (documentation 'frob 'structure) "NEW5"))
180
181 (define-compiler-macro cmacro (x)
182   "compiler macro"
183   x)
184
185 (define-compiler-macro (setf cmacro) (y x)
186   "setf compiler macro"
187   y)
188
189 (with-test (:name (documentation compiler-macro))
190   (unless (equal "compiler macro"
191                  (documentation 'cmacro 'compiler-macro))
192     (error "got ~S for cmacro"
193            (documentation 'cmacro 'compiler-macro)))
194   (unless (equal "setf compiler macro"
195                  (documentation '(setf cmacro) 'compiler-macro))
196     (error "got ~S for setf macro" (documentation '(setf cmacro) 'compiler-macro))))
197
198 (with-test (:name (documentation lambda))
199   (let ((f (lambda () "aos the zos" t))
200         (g (sb-int:named-lambda fii () "zoot the fruit" t)))
201     (dolist (doc-type '(t function))
202       (assert (string= (documentation f doc-type) "aos the zos"))
203       (assert (string= (documentation g doc-type) "zoot the fruit")))
204     (setf (documentation f t) "fire")
205     (assert (string= (documentation f t) "fire"))
206     (assert (string= (documentation g t) "zoot the fruit"))))
207
208 (with-test (:name (documentation flet))
209   (assert
210    (string= (documentation
211              (flet ((quux (x)
212                       "this is FLET quux"
213                       (/ x 2)))
214                #'quux)
215              t)
216             "this is FLET quux")))
217
218 (with-test (:name (documentation labels))
219   (assert
220    (string= (documentation
221              (labels ((rec (x)
222                         "this is LABELS rec"
223                         (if (plusp x)
224                             (* x (rec (1- x)))
225                             1)))
226                #'rec)
227              t)
228             "this is LABELS rec")))
229
230 (let ((x 1))
231   (defun docfoo (y)
232     "bar"
233     (incf x y)))
234
235 (with-test (:name (documentation closure))
236   (assert (string= (documentation 'docfoo 'function) "bar"))
237   (assert (string= (documentation #'docfoo t) "bar"))
238   (assert (string= (setf (documentation 'docfoo 'function) "baz") "baz"))
239   (assert (string= (documentation 'docfoo 'function) "baz"))
240   (assert (string= (documentation #'docfoo t) "bar"))
241   (assert (string= (setf (documentation #'docfoo t) "zot") "zot"))
242   (assert (string= (documentation #'docfoo t) "zot"))
243   (assert (string= (documentation 'docfoo 'function) "baz"))
244   (assert (not (setf (documentation 'docfoo 'function) nil)))
245   (assert (string= (documentation 'docfoo 'function) "zot")))
246
247 (with-test (:name (documentation built-in-macro) :skipped-on '(not :sb-doc))
248   (assert (documentation 'trace 'function)))
249
250 (with-test (:name (documentation built-in-function) :skipped-on '(not :sb-doc))
251   (assert (documentation 'cons 'function)))
252
253 (with-test (:name :describe-generic-function-with-assumed-type)
254   ;; Signalled an error at one point
255   (flet ((zoo () (gogo)))
256     (defmethod gogo () nil)
257     (describe 'gogo)))
258
259 (defmacro bug-643958-test ()
260   "foo"
261   :ding!)
262
263 (with-test (:name :bug-643958)
264   (assert (equal "foo" (documentation 'bug-643958-test 'function)))
265   (setf (documentation 'bug-643958-test 'function) "bar")
266   (assert (equal "bar" (documentation 'bug-643958-test 'function))))
267
268 (defclass cannot-print-this ()
269   ())
270 (defmethod print-object ((oops cannot-print-this) stream)
271   (error "No go!"))
272 (with-test (:name :describe-suppresses-print-errors)
273   (handler-bind ((error #'continue))
274     (with-output-to-string (s)
275       (describe (make-instance 'cannot-print-this) s))))
276 (with-test (:name :backtrace-suppresses-print-errors)
277   (handler-bind ((error #'continue))
278     (with-output-to-string (s)
279       (labels ((foo (n x)
280                  (when (plusp n)
281                    (foo (1- n) x))
282                  (when (zerop n)
283                    (sb-debug:backtrace 100 s))))
284         (foo 100 (make-instance 'cannot-print-this))))))
285 (with-test (:name :backtrace-and-circles)
286   (handler-bind ((error #'continue))
287     (with-output-to-string (s)
288       (labels ((foo (n x)
289                  (when (plusp n)
290                    (foo (1- n) x))
291                  (when (zerop n)
292                    (sb-debug:backtrace 100 s))))
293         (foo 100 (let ((list (list t)))
294                    (nconc list list)))))))
295
296 (with-test (:name :endianness-in-features)
297   (assert
298    (or (member :big-endian *features*)
299        (member :little-endian *features*))))
300 \f
301 ;;;; success