1 ;;;; miscellaneous compiler tests with side effects (e.g. DEFUN
2 ;;;; changing FDEFINITIONs and globaldb stuff)
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (declaim (optimize (debug 3) (speed 2) (space 1)))
17 ;;; Until version 0.6.9 or so, SBCL's version of Python couldn't do
18 ;;; this correctly, due to the bug patched by Rob MacLachlan on the
19 ;;; cmucl-imp list 2000-06-21, and applied to SBCL by Martin Atzmueller.
20 ;;; (The effectiveness of the test also depends on the implicit
21 ;;; function typing of Python (where DEFUN is like DECLAIM FTYPE),
22 ;;; which violates the ANSI spec, and should be fixed. Once that
23 ;;; unrelated bug is fixed, this code will no longer test the type
24 ;;; inference behavior it's intended to test.)
25 (defun emptyvalues (&rest rest
) (declare (ignore rest
)) (values))
28 (let ((res (emptyvalues)))
29 (unless (typep res
'foo
)
31 (assert (eq (bar0) 'expected-value
))
33 (declaim (ftype (function (real) (values integer single-float
)) valuesify
))
36 (coerce x
'single-float
)))
37 (defun exercise-valuesify (x)
38 (multiple-value-bind (i f
) (valuesify x
)
39 (declare (type integer i
))
40 (declare (type single-float f
))
42 (assert (= (exercise-valuesify 1.25) 2.25))
44 ;;; An early version (sbcl-0.6.11.33) of code to check FTYPEs from DEFUN
45 ;;; against DECLAIMed FTYPEs blew up when an FTYPE was DECLAIMed
46 ;;; to be pure FUNCTION, because the internal representation of
47 ;;; FUNCTION itself (as opposed to subtypes of FUNCTION, such as
48 ;;; (FUNCTION () T)) is a BUILT-IN-CLASS object, not a FUN-TYPE
50 (declaim (ftype function i-am-just-a-function
))
51 (defun i-am-just-a-function (x y
) (+ x y
1))
53 ;;; Stig E Sandoe reported in cclan-Bugs-431263 that SBCL couldn't
54 ;;; compile this. sbcl-0.6.12.26 died in CIRCULAR-LIST-P with "The
55 ;;; value \"EST\" is not of type LIST." Dan Barlow fixed it.
57 '((5 "EDT" .
"EST") (6 "CDT" .
"CST") (7 "MDT" .
58 "MST") (8 "PDT" .
"PST")
59 (0 "GMT" .
"GDT") (-2 "MET" .
"MET DST"))
60 "*The string representations of the time zones.")
62 (declaim (optimize (debug 1) (speed 1) (space 1)))
64 ;;; The old CMU CL Python compiler assumed that it was safe to infer
65 ;;; function types (including return types) from function definitions
66 ;;; and then use them to optimize code later [and it was almost
67 ;;; right!]. This is of course bad when functions are redefined. The
68 ;;; problem was fixed in sbcl-0.6.12.57.
74 (defun bar1 (x) ; don't conflict with BAR from the test way up top
81 (assert (eql (bar1 11) :real
))
82 (assert (eql (bar1 -
11) :fixnum
))
83 (setf (symbol-function 'foo1
) #'identity
)
84 (assert (eql (bar1 11) :fixnum
))
85 (assert (eql (bar1 -
11.0) :real
))
86 (assert (eql (bar1 "this is a test") :string
))
87 (assert (eql (bar1 (make-hash-table)) :t
))
89 ;;; bug reported by Brian Spilsbury sbcl-devel 2001-09-30, fixed by
90 ;;; Alexey Dejneka patch sbcl-devel 2001-10-02
91 (defun pixarray-element-size (pixarray)
92 (let ((eltype (array-element-type pixarray
)))
93 (cond ((eq eltype
'bit
) 1)
95 (eq (first eltype
) 'unsigned-byte
))
98 (error "Invalid pixarray: ~S." pixarray
)))))
99 (assert (eql 1 (pixarray-element-size #*110)))
101 ;;; bug 31 turned out to be a manifestation of non-ANSI array type
102 ;;; handling, fixed by CSR in sbcl-0.7.3.8.
103 (defun array-element-type-handling (x)
104 (declare (optimize safety
))
105 (declare (type (vector cons
) x
))
106 (when (consp (aref x
0))
109 (array-element-type-handling
110 (make-array 3 :element-type t
:initial-element
0))
113 ;;; bug 220: type check inserted after all arguments in MV-CALL caused
114 ;;; failure of stack analysis
115 (defun bug220-helper ()
117 (assert (equal (multiple-value-call #'list
118 (the integer
(bug220-helper))
122 ;;; bug 221: sbcl 0.7.9.13 failed to compile the following function
123 (declaim (ftype (function (fixnum) (values package boolean
)) bug221-f1
))
124 (declaim (ftype (function (t) (values package boolean
)) bug221-f2
))
126 (funcall (if b
#'bug221-f1
#'bug221-f2
) x
))
128 ;;; bug 166: compiler failure
130 (defmethod permanentize ((uustk bug166s
))
131 (flet ((frob (hash-table test-for-deletion
)
133 (obj-entry.stale?
(oe)
134 (destructuring-bind (key . datum
) oe
135 (declare (type simple-vector key
))
136 (deny0 (void? datum
))
137 (some #'stale? key
))))
138 (declare (inline frob obj-entry.stale?
))
139 (frob (uustk.args-hash-
>obj-alist uustk
)
141 (frob (uustk.hash-
>memoized-objs-list uustk
)
145 ;;; bugs 115, 226: compiler failure in lifetime analysis
147 (declare (optimize (speed 2) (debug 3)))
149 (unwind-protect nil
)))
155 (declare (optimize (speed 2) (debug 3)))
157 (bar2 (if (foo0) 1 2))
164 ;;; bug 231: SETQ did not check the type of the variable being set
166 (declare (optimize safety
) (type (integer 0 8) x
))
168 (assert-error (bug231a-1 8) type-error
)
171 (declare (optimize safety
) (type (integer 0 8) x
))
172 (list (lambda (y) (setq x y
))
174 (destructuring-bind (set get
) (bug231a-2 0)
176 (assert (eql (funcall get
) 8))
177 (assert-error (funcall set
9) type-error
)
178 (assert (eql (funcall get
) 8)))
181 (declare (optimize safety
) (type integer x
))
183 (declare (type (real 1) x
))
186 (assert-error (bug231b (eval 'nil
) 1) type-error
)
187 (assert-error (bug231b 0 1.5) type-error
)
188 (assert-error (bug231b 0 0) type-error
)
190 ;;; A bug appeared in flaky7_branch. Python got lost in unconverting
191 ;;; embedded tail calls during let-conversion.
192 (defun bug239 (bit-array-2 &optional result-bit-array
)
193 (declare (type (array bit
) bit-array-2
)
194 (type (or (array bit
) (member t nil
)) result-bit-array
))
195 (unless (simple-bit-vector-p bit-array-2
)
197 (lambda (data1 start1
)
199 (lambda (data2 start2
)
201 (lambda (data3 start3
)
202 (declare (ignore start3
))
203 (print (list data1 data2
)))
205 (values bit-array-2
0)))
207 (assert (equal (bug239 (make-array 4 :element-type
'bit
213 (defstruct some-structure a
)
214 (eval-when (:compile-toplevel
)
215 ;; in the big CLASS reorganization in pre8, this would fail with
216 ;; SOME-STRUCTURE-A is not FBOUNDP. Fixed in 0.pre8.64
217 (find-class 'some-structure nil
))
218 (eval-when (:load-toplevel
)
219 (assert (typep (find-class 'some-structure
) 'class
)))
221 ;; When loading from fasl, if a form in that file tried referencing
222 ;; compiled-debug-info for a function provided earlier in that same file,
223 ;; it wouldn't work because the earlier function's #<code> component is
224 ;; present but without its debug-info-source, which is dumped later.
225 (defun f1 (x) (+ x
3))
226 ;; There's nothing to assert other than that this works.
227 (print (multiple-value-list (function-lambda-expression #'f1
)))
229 ;; It's possible for an instance to refer to a LAYOUT that has no classoid.
230 ;; This can arise from one file compiling a defstruct and another file compiling
231 ;; a function that refers to an instance of it as a literal either from
232 ;; LOAD-TIME-VALUE or MAKE-LOAD-FORM. Then you restart lisp and load the second
233 ;; but not the first file. A function to recreate the instance was correctly
234 ;; dumped, but everything including the disassembler would crash trying to view
235 ;; the resultant object.
237 (eval-when (:compile-toplevel
)
238 (declaim (inline make-my-awesome-struct
))
239 (defstruct (my-awesome-struct (:predicate nil
) (:copier nil
)) a b c
)
240 (defmethod make-load-form ((self my-awesome-struct
) &optional env
)
241 (declare (ignore env
))
242 ;; Can't use MAKE-LOAD-FORM-SAVING-SLOTS
243 ;; because that goes (ALLOCATE-INSTANCE (FIND-CLASS 'MY-AWESOME-STRUCT).
244 ;; Our named constructor is inlined and doesn't need the class.
245 (with-slots (a b c
) self
`(make-my-awesome-struct :a
',a
:b
',b
:c
',c
)))
246 (defvar *my-awesome-instance
*
247 (make-my-awesome-struct :a
1 :b
'(foo .
#*101) :c
#(4 5 3))))
250 ;; use a macro to return the object itself, not the symbol naming it.
251 (macrolet ((it () *my-awesome-instance
*))
254 (defun get-foo-val (x) (my-awesome-struct-b x
))
256 ;; This approximates the test case - no class's proper name is MY-AWESOME-STRUCT.
257 ;; The old metaobjects are detritus in the object hierarchy but don't affect
258 ;; corectness of the test.
259 (eval-when (:compile-toplevel
)
260 (dolist (sym '("MY-AWESOME-STRUCT" "MY-AWESOME-STRUCT-A"
261 "MY-AWESOME-STRUCT-B" "MY-AWESOME-STRUCT-C"))
262 (unintern (find-symbol sym
))))
264 (assert (not (find-class 'my-awesome-struct nil
)))
266 (let ((x (trythis 9))
267 (*print-pretty
* nil
))
268 (format t
"~&Hi! ~S~%" x
)
269 (assert (search "UNPRINTABLE" (write-to-string x
)))
270 (assert (equal (get-foo-val (second x
)) '(foo .
#*101))))