1 ;;;; tests for problems in the interface presented to the user/programmer
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "assertoid.lisp")
15 (load "test-util.lisp")
16 (use-package "ASSERTOID")
17 (use-package "TEST-UTIL")
20 "(setf foo) documentation"
23 (assert (string= (documentation '(setf foo
) 'function
)
24 "(setf foo) documentation"))
25 (assert (string= (documentation #'(setf foo
) 'function
)
26 "(setf foo) documentation"))
28 (assert (string= (documentation '(setf foo
) 'function
)
29 "(setf foo) documentation"))
30 (assert (string= (documentation #'(setf foo
) 'function
)
31 "(setf foo) documentation"))
33 ;;; DISASSEMBLE shouldn't fail on closures or unpurified functions
34 (defun disassemble-fun (x) x
)
35 (disassemble 'disassemble-fun
)
37 (let ((x 1)) (defun disassemble-closure (y) (if y
(setq x y
) x
)))
38 (disassemble 'disassemble-closure
)
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
))
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
)))
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
)))
59 ;;; while we're at it, much the same applies to
60 ;;; FUNCTION-LAMBDA-EXPRESSION:
62 (function-lambda-expression #'fle-fun
)
64 (let ((x 1)) (defun fle-closure (y) (if y
(setq x y
) x
)))
65 (function-lambda-expression #'fle-closure
)
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
))
74 ;; fle-eval should still be an interpreted function.
75 (assert (sb-eval:interpreted-function-p
#'fle-eval
)))
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
))
83 ;;; support for DESCRIBE tests
84 (defstruct to-be-described a b
)
85 (defclass forward-describe-class
(forward-describe-ref) (a))
87 ;;; DESCRIBE should run without signalling an error.
88 (describe (make-to-be-described))
92 (describe (find-package :cl
))
94 (describe #(a vector
))
96 ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do
97 ;;; FRESH-LINE and TERPRI neatly.
98 (dolist (i (list (make-to-be-described :a
14) 12 "a string"
99 #0a0
#(1 2 3) #2a
((1 2) (3 4)) 'sym
:keyword
100 (find-package :keyword
) (list 1 2 3)
101 nil
(cons 1 2) (make-hash-table)
102 (let ((h (make-hash-table)))
103 (setf (gethash 10 h
) 100
106 (make-condition 'simple-error
)
107 (make-condition 'simple-error
:format-control
"fc")
108 #'car
#'make-to-be-described
(lambda (x) (+ x
11))
109 (constantly 'foo
) #'(setf to-be-described-a
)
110 #'describe-object
(find-class 'to-be-described
)
111 (find-class 'forward-describe-class
)
112 (find-class 'forward-describe-ref
) (find-class 'cons
)))
113 (let ((s (with-output-to-string (s)
116 (unless (and (char= #\x
(char s
0))
117 ;; one leading #\NEWLINE from FRESH-LINE or the like, no more
118 (char= #\newline
(char s
1))
119 (char/= #\newline
(char s
2))
120 ;; one trailing #\NEWLINE from TERPRI or the like, no more
121 (let ((n (length s
)))
122 (and (char= #\newline
(char s
(- n
1)))
123 (char/= #\newline
(char s
(- n
2))))))
124 (error "misbehavior in DESCRIBE of ~S" i
))))
127 ;;; Tests of documentation on types and classes
130 (:documentation
"FOO"))
131 (defstruct bar
"BAR")
132 (define-condition baz
()
134 (:documentation
"BAZ"))
138 (defstruct (frob (:type vector
)) "FROB")
140 ((do-class (name expected
&optional structurep
)
142 (assert (string= (documentation ',name
'type
) ,expected
))
143 (assert (string= (documentation (find-class ',name
) 'type
) ,expected
))
144 (assert (string= (documentation (find-class ',name
) 't
) ,expected
))
146 `((assert (string= (documentation ',name
'structure
) ,expected
))))
147 (let ((new1 (symbol-name (gensym "NEW1")))
148 (new2 (symbol-name (gensym "NEW2")))
149 (new3 (symbol-name (gensym "NEW3")))
150 (new4 (symbol-name (gensym "NEW4"))))
151 (declare (ignorable new4
))
152 (setf (documentation ',name
'type
) new1
)
153 (assert (string= (documentation (find-class ',name
) 'type
) new1
))
154 (setf (documentation (find-class ',name
) 'type
) new2
)
155 (assert (string= (documentation (find-class ',name
) 't
) new2
))
156 (setf (documentation (find-class ',name
) 't
) new3
)
157 (assert (string= (documentation ',name
'type
) new3
))
159 `((assert (string= (documentation ',name
'structure
) new3
))
160 (setf (documentation ',name
'structure
) new4
)
161 (assert (string= (documentation ',name
'structure
) new4
))))))))
163 (do-class bar
"BAR" t
)
164 (do-class baz
"BAZ"))
166 (assert (string= (documentation 'quux
'type
) "QUUX"))
167 (setf (documentation 'quux
'type
) "NEW4")
168 (assert (string= (documentation 'quux
'type
) "NEW4"))
170 (assert (string= (documentation 'frob
'structure
) "FROB"))
171 (setf (documentation 'frob
'structure
) "NEW5")
172 (assert (string= (documentation 'frob
'structure
) "NEW5"))
174 (define-compiler-macro cmacro
(x)
178 (define-compiler-macro (setf cmacro
) (y x
)
179 "setf compiler macro"
182 (with-test (:name
(documentation compiler-macro
))
183 (unless (equal "compiler macro"
184 (documentation 'cmacro
'compiler-macro
))
185 (error "got ~S for cmacro"
186 (documentation 'cmacro
'compiler-macro
)))
187 (unless (equal "setf compiler macro"
188 (documentation '(setf cmacro
) 'compiler-macro
))
189 (error "got ~S for setf macro" (documentation '(setf cmacro
) 'compiler-macro
))))
191 (with-test (:name
(documentation lambda
))
192 (let ((f (lambda () "aos the zos" t
))
193 (g (sb-int:named-lambda fii
() "zoot the fruit" t
)))
194 (dolist (doc-type '(t function
))
195 (assert (string= (documentation f doc-type
) "aos the zos"))
196 (assert (string= (documentation g doc-type
) "zoot the fruit")))
197 (setf (documentation f t
) "fire")
198 (assert (string= (documentation f t
) "fire"))
199 (assert (string= (documentation g t
) "zoot the fruit"))))
201 (with-test (:name
(documentation flet
))
203 (string= (documentation
209 "this is FLET quux")))
211 (with-test (:name
(documentation labels
))
213 (string= (documentation
221 "this is LABELS rec")))
228 (with-test (:name
(documentation closure
))
229 (assert (string= (documentation 'docfoo
'function
) "bar"))
230 (assert (string= (documentation #'docfoo t
) "bar"))
231 (assert (string= (setf (documentation 'docfoo
'function
) "baz") "baz"))
232 (assert (string= (documentation 'docfoo
'function
) "baz"))
233 (assert (string= (documentation #'docfoo t
) "baz")))
236 (with-test (:name
(documentation built-in-macro
))
237 (assert (documentation 'trace
'function
)))
240 (with-test (:name
(documentation built-in-function
))
241 (assert (documentation 'cons
'function
)))