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