1 ;;;; This file is for compiler tests which have side effects (e.g.
2 ;;;; executing DEFUN) but which don't need any special side-effecting
3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
4 ;;;; settings). Similar tests which *do* expect special settings may
5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
18 (cl:in-package
:cl-user
)
20 ;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN)
21 ;;; was messed up so badly that trying to execute expressions like
22 ;;; this signalled an error.
23 (with-test (:name
(setf extern-alien
))
24 (setf (sb-alien:extern-alien
"thread_control_stack_size" sb-alien
:unsigned
)
25 (sb-alien:extern-alien
"thread_control_stack_size" sb-alien
:unsigned
)))
27 ;;; bug 133, fixed in 0.7.0.5: Somewhere in 0.pre7.*, C void returns
28 ;;; were broken ("unable to use values types here") when
29 ;;; auto-PROCLAIM-of-return-value was added to DEFINE-ALIEN-ROUTINE.
30 (with-test (:name
(define-alien-routine :bug-133
))
31 (sb-alien:define-alien-routine
("free" free
) void
(ptr (* t
) :in
)))
33 ;;; Types of alien functions were being incorrectly DECLAIMED when
34 ;;; docstrings were included in the definition until sbcl-0.7.6.15.
35 (sb-alien:define-alien-routine
("getenv" ftype-correctness
) c-string
39 (with-test (:name
(define-alien-routine ftype
:correctness
))
40 (multiple-value-bind (function failure-p warnings
)
41 (checked-compile '(lambda () (ftype-correctness))
43 (declare (ignore function failure-p
))
44 (assert (= (length warnings
) 1)))
46 (checked-compile '(lambda () (ftype-correctness "FOO")))
48 (multiple-value-bind (function failure-p warnings
)
49 (checked-compile '(lambda () (ftype-correctness "FOO" "BAR"))
51 (declare (ignore function failure-p
))
52 (assert (= (length warnings
) 1))))
54 ;;; This used to break due to too eager auxiliary type twiddling in
55 ;;; parse-alien-record-type.
56 (defparameter *maybe
* nil
)
57 (with-test (:name
(with-alien struct
:and alien-funcall
))
60 (with-alien ((x (struct bar
(x unsigned
) (y unsigned
)))
61 ;; bogus definition, but we just need the symbol
62 (f (function int
(* (struct bar
))) :extern
"printf"))
64 (alien-funcall f
(addr x
)))))))
66 ;;; Mutually referent structures
67 (define-alien-type struct
.1 (struct struct
.1 (x (* (struct struct
.2))) (y int
)))
68 (define-alien-type struct
.2 (struct struct
.2 (x (* (struct struct
.1))) (y int
)))
69 (with-test (:name
(define-alien-type :mutually-reference-structures
))
70 (let ((s1 (make-alien struct
.1))
71 (s2 (make-alien struct
.2)))
74 (slot (slot s1
'x
) 'y
) 1
75 (slot (slot s2
'x
) 'y
) 2)
76 (assert (= 1 (slot (slot s1
'x
) 'y
)))
77 (assert (= 2 (slot (slot s2
'x
) 'y
)))))
79 ;;; "Alien bug" on sbcl-devel 2004-10-11 by Thomas F. Burdick caused
80 ;;; by recursive struct definition.
81 (with-test (:name
(compile-file :nested define-alien-type struct
))
82 (let ((fname "alien-bug-2004-10-11.tmp.lisp"))
85 (with-open-file (f fname
:direction
:output
:if-exists
:supersede
)
86 (mapc (lambda (form) (print form f
))
87 '((defpackage :alien-bug
89 (in-package :alien-bug
)
90 (define-alien-type objc-class
93 (* (struct protocol-list
94 (list (array (* (struct objc-class
))))))))))))
97 (load (compile-file fname
))
98 (load (compile-file fname
)))
99 (delete-file (compile-file-pathname fname
))
100 (delete-file fname
))))
102 ;;; enumerations with only one enum resulted in division-by-zero
103 ;;; reported on sbcl-help 2004-11-16 by John Morrison
104 (define-alien-type enum
.1 (enum nil
(:val0
0)))
106 (define-alien-type enum
.2 (enum nil
(zero 0) (one 1) (two 2) (three 3)
107 (four 4) (five 5) (six 6) (seven 7)
109 (with-test (:name
(define-alien-type enum array cast
))
110 (with-alien ((integer-array (array int
3)))
111 (let ((enum-array (cast integer-array
(array enum
.2 3))))
112 (setf (deref enum-array
0) 'three
113 (deref enum-array
1) 'four
)
114 (setf (deref integer-array
2) (+ (deref integer-array
0)
115 (deref integer-array
1)))
116 (assert (eql (deref enum-array
2) 'seven
)))))
118 ;; The code that is used for mapping from integers to symbols depends
119 ;; on the `density' of the set of used integers, so test with a sparse
121 (define-alien-type enum
.3 (enum nil
(zero 0) (one 1) (k-one 1001) (k-two 1002)))
122 (with-test (:name
(define-alien-type enum
:sparse-integers
))
123 (with-alien ((integer-array (array int
3)))
124 (let ((enum-array (cast integer-array
(array enum
.3 3))))
125 (setf (deref enum-array
0) 'one
126 (deref enum-array
1) 'k-one
)
127 (setf (deref integer-array
2) (+ (deref integer-array
0)
128 (deref integer-array
1)))
129 (assert (eql (deref enum-array
2) 'k-two
)))))
131 ;; enums used to allow values to be used only once
132 ;; C enums allow for multiple tags to point to the same value
133 (define-alien-type enum
.4
134 (enum nil
(:key1
1) (:key2
2) (:keytwo
2)))
135 (with-test (:name
(define-alien-type enum
:repeated-integers
))
136 (with-alien ((enum-array (array enum
.4 3)))
137 (setf (deref enum-array
0) :key1
)
138 (setf (deref enum-array
1) :key2
)
139 (setf (deref enum-array
2) :keytwo
)
140 (assert (and (eql (deref enum-array
1) (deref enum-array
2))
141 (eql (deref enum-array
1) :key2
)))))
143 ;;; As reported by Baughn on #lisp, ALIEN-FUNCALL loops forever when
144 ;;; compiled with (DEBUG 3).
145 (with-test (:name
(alien-funcall debug
3))
146 (sb-kernel::values-specifier-type-cache-clear
)
147 (checked-compile-and-assert ()
149 (sb-alien:alien-funcall
(sb-alien:extern-alien
"getenv"
150 (function (c-string) c-string
))
152 (("HOME") '(or string null
) :test
(lambda (values expected
)
153 (every #'typep values expected
)))))
155 ;;; CLH: Test for non-standard alignment in alien structs
156 (sb-alien:define-alien-type align-test-struct
157 (sb-alien:union align-test-union
158 (s (sb-alien:struct nil
159 (s1 sb-alien
:unsigned-char
)
160 (c1 sb-alien
:unsigned-char
:alignment
16)
161 (c2 sb-alien
:unsigned-char
:alignment
32)
162 (c3 sb-alien
:unsigned-char
:alignment
32)
163 (c4 sb-alien
:unsigned-char
:alignment
8)))
164 (u (sb-alien:array sb-alien
:unsigned-char
16))))
165 (with-test (:name
(define-alien-type struct
:alignment
))
166 (let ((a1 (sb-alien:make-alien align-test-struct
)))
167 (declare (type (sb-alien:alien
(* align-test-struct
)) a1
))
168 (setf (sb-alien:slot
(sb-alien:slot a1
's
) 's1
) 1)
169 (setf (sb-alien:slot
(sb-alien:slot a1
's
) 'c1
) 21)
170 (setf (sb-alien:slot
(sb-alien:slot a1
's
) 'c2
) 41)
171 (setf (sb-alien:slot
(sb-alien:slot a1
's
) 'c3
) 61)
172 (setf (sb-alien:slot
(sb-alien:slot a1
's
) 'c4
) 81)
173 (assert (equal '(1 21 41 61 81)
174 (list (sb-alien:deref
(sb-alien:slot a1
'u
) 0)
175 (sb-alien:deref
(sb-alien:slot a1
'u
) 2)
176 (sb-alien:deref
(sb-alien:slot a1
'u
) 4)
177 (sb-alien:deref
(sb-alien:slot a1
'u
) 8)
178 (sb-alien:deref
(sb-alien:slot a1
'u
) 9))))))
180 (with-test (:name
(make-alien :no-note
))
181 (checked-compile-and-assert (:allow-notes nil
)
182 '(lambda () (sb-alien:make-alien sb-alien
:int
))
183 (() 'sb-alien
:alien
:test
#'typep
)))
185 ;;; Test case for unwinding an alien (Win32) exception frame
187 ;;; The basic theory here is that failing to honor a win32
188 ;;; exception frame during stack unwinding breaks the chain.
189 ;;; "And if / You don't love me now / You will never love me
190 ;;; again / I can still hear you saying / You would never break
191 ;;; the chain." If the chain is broken and another exception
192 ;;; occurs (such as an error trap caused by an OBJECT-NOT-TYPE
193 ;;; error), the system will kill our process. No mercy, no
194 ;;; appeal. So, to check that we have done our job properly, we
195 ;;; need some way to put an exception frame on the stack and then
196 ;;; unwind through it, then trigger another exception. (FUNCALL
197 ;;; 0) will suffice for the latter, and a simple test shows that
198 ;;; CallWindowProc() establishes a frame and calls a function
199 ;;; passed to it as an argument.
202 (load-shared-object "USER32")
208 (extern-alien "CallWindowProcW"
209 (function unsigned-int
210 (* (function int
)) unsigned-int
211 unsigned-int unsigned-int unsigned-int
))
213 (sb-alien::alien-callback
(function unsigned-int
)
214 #'(lambda () (go up
))))
221 ;;; Unused local alien caused a compiler error
222 (with-test (:name
(sb-alien:with-alien
:unused
:no error
))
223 (checked-compile-and-assert ()
225 (sb-alien:with-alien
((alien1923 (array (sb-alien:unsigned
8) 72)))
229 ;;; Non-local exit from WITH-ALIEN caused alien stack to be leaked.
231 (defun try-to-leak-alien-stack (x)
232 (with-alien ((alien (array (sb-alien:unsigned
8) 72)))
233 (let ((sap-int (sb-sys:sap-int
(alien-sap alien
))))
235 (assert (= *sap-int
* sap-int
))
236 (setf *sap-int
* sap-int
)))
238 (return-from try-to-leak-alien-stack
'going
))
239 (locally (declare (muffle-conditions style-warning
))
241 (with-test (:name
:nlx-causes-alien-stack-leak
242 :fails-on
:interpreter
) ; should it work?
243 (let ((*sap-int
* nil
))
245 do
(try-to-leak-alien-stack t
))))
247 (with-test (:name
(define-alien-type struct
:redefinition
:bug-431
)
248 :fails-on
:interpreter
)
250 (define-alien-type nil
(struct mystruct
(myshort short
) (mychar char
)))
251 (with-alien ((myst (struct mystruct
)))
252 (with-alien ((mysh short
(slot myst
'myshort
)))
253 (assert (integerp mysh
))))))
255 (handler-bind ((error (lambda (e)
256 (let ((cont (find-restart 'continue e
)))
259 (invoke-restart cont
))))))
260 (eval '(define-alien-type nil
(struct mystruct
(myint int
) (mychar char
)))))
261 (assert (= 1 restarted
)))
262 (eval '(with-alien ((myst (struct mystruct
)))
263 (with-alien ((myin int
(slot myst
'myint
)))
264 (assert (integerp myin
))))))
266 ;;; void conflicted with derived type
267 (declaim (inline bug-316075
))
268 ;; KLUDGE: This win32 reader conditional masks a bug, but allows the
269 ;; test to fail cleanly. The linkage-table reader conditional
270 ;; accomodates the little fact that the function doesn't exist, and
271 ;; non-linkage-table systems resolve such things immediately and
273 #-
(or win32
(not linkage-table
))
274 (locally (declare (muffle-conditions style-warning
))
275 (sb-alien:define-alien-routine bug-316075 void
(result char
:out
)))
276 (with-test (:name
:bug-316075
:fails-on
:win32
277 :broken-on
(not :linkage-table
))
278 #+win32
(error "fail")
279 #-linkage-table
(error "unable to set up test precondition")
280 ;; The interpreter gives you a style-warning because the "undefined alien"
281 ;; first occurs here during compilation of the test case. But if compiling
282 ;; by default, then the warning already happened above at DEFINE-ALIEN-ROUTINE
283 ;; because when that got compiled, it warned, which inhibited further
284 ;; warnings for the same foreign symbol.
285 (checked-compile '(lambda () (multiple-value-list (bug-316075)))
286 :allow-style-warnings t
))
288 ;;; Bug #316325: "return values of alien calls assumed truncated to
289 ;;; correct width on x86"
291 (sb-alien::define-alien-callback truncation-test
(unsigned 64)
292 ((foo (unsigned 64)))
295 (sb-alien::define-alien-callback truncation-test
(unsigned 32)
296 ((foo (unsigned 32)))
299 (with-test (:name
:bug-316325
:skipped-on
(not (or :x86-64
:x86
))
300 :fails-on
:interpreter
)
301 ;; This test works by defining a callback function that provides an
302 ;; identity transform over a full-width machine word, then calling
303 ;; it as if it returned a narrower type and checking to see if any
304 ;; noise in the high bits of the result are properly ignored.
305 (macrolet ((verify (type input output
)
306 `(with-alien ((fun (* (function ,type
307 #+x86-64
(unsigned 64)
308 #+x86
(unsigned 32)))
309 :local
(alien-sap truncation-test
)))
310 (let ((result (alien-funcall fun
,input
)))
311 (assert (= result
,output
))))))
314 (verify (unsigned 64) #x8000000000000000
#x8000000000000000
)
315 (verify (signed 64) #x8000000000000000
#x-8000000000000000
)
316 (verify (signed 64) #x7fffffffffffffff
#x7fffffffffffffff
)
317 (verify (unsigned 32) #x0000000180000042
#x80000042
)
318 (verify (signed 32) #x0000000180000042
#x-7fffffbe
)
319 (verify (signed 32) #xffffffff7fffffff
#x7fffffff
))
322 (verify (unsigned 32) #x80000042
#x80000042
)
323 (verify (signed 32) #x80000042
#x-7fffffbe
)
324 (verify (signed 32) #x7fffffff
#x7fffffff
))
325 (verify (unsigned 16) #x00018042
#x8042
)
326 (verify (signed 16) #x003f8042
#x-7fbe
)
327 (verify (signed 16) #x003f7042
#x7042
)))
329 (with-test (:name
:bug-654485
)
330 ;; DEBUG 2 used to prevent let-conversion of the open-coded ALIEN-FUNCALL body,
331 ;; which in turn led the dreaded %SAP-ALIEN note.
333 `(lambda (program argv
)
334 (declare (optimize (debug 2)))
335 (with-alien ((sys-execv1 (function int c-string
(* c-string
)) :extern
337 (values (alien-funcall sys-execv1 program argv
))))
340 (with-test (:name
:bug-721087
:fails-on
:win32
)
341 (assert (typep nil
'(alien c-string
)))
342 (assert (not (typep nil
'(alien (c-string :not-null t
)))))
347 (when (and (null (type-error-datum e
))
348 (equal (type-error-expected-type e
)
349 '(alien (c-string :not-null t
))))
352 (with-test (:name
:make-alien-string
)
353 (labels ((content (alien length null-terminate
)
355 (cast alien c-string
)
356 (let ((buffer (make-array length
357 :element-type
'(unsigned-byte 8))))
358 (sb-kernel:copy-ub8-from-system-area
359 (alien-sap alien
) 0 buffer
0 length
)
360 (sb-ext:octets-to-string buffer
))))
361 (test (null-terminate)
362 (let* ((string "This comes from lisp!")
363 (length (length string
)))
364 (multiple-value-bind (alien alien-length
)
365 (sb-alien::make-alien-string
366 string
:null-terminate null-terminate
)
367 (assert (= alien-length
(+ length
(if null-terminate
1 0))))
369 ;; Copy to make sure STRING did not somehow end up in
371 (assert (equal (copy-seq string
)
372 (content alien length null-terminate
)))
373 (free-alien alien
)))))
377 (with-test (:name
:malloc-failure
378 :fails-on
:alpha
) ;; Alpha has address space to burn
382 collect
(sb-alien:make-alien char
(1- array-total-size-limit
)))
383 (storage-condition ()
386 (with-test (:name
:bug-985505
)
387 ;; Check that correct octets are reported for a c-string-decoding error.
391 (let ((c-string (coerce #(70 111 195 182 0)
392 '(vector (unsigned-byte 8)))))
393 (sb-sys:with-pinned-objects
(c-string)
394 (sb-alien::c-string-to-string
(sb-sys:vector-sap c-string
)
396 (sb-int:c-string-decoding-error
(e)
397 (assert (equalp #(195) (sb-int:character-decoding-error-octets e
)))
404 ;; C-STRING decoding doesn't know how long the string is, and since this
405 ;; looks like a 4-byte sequence, it will grab 4 octets off the end.
407 ;; So we pad the vector for safety's sake.
408 (let ((c-string (coerce #(70 111 246 0 0 0)
409 '(vector (unsigned-byte 8)))))
410 (sb-sys:with-pinned-objects
(c-string)
411 (sb-alien::c-string-to-string
(sb-sys:vector-sap c-string
)
413 (sb-int:c-string-decoding-error
(e)
414 (assert (equalp #(246 0 0 0)
415 (sb-int:character-decoding-error-octets e
)))
420 (let ((c-string (coerce #(70 195 1 182 195 182 0) '(vector (unsigned-byte 8)))))
421 (sb-sys:with-pinned-objects
(c-string)
422 (sb-alien::c-string-to-string
(sb-sys:vector-sap c-string
)
424 (sb-int:c-string-decoding-error
(e)
425 (assert (equalp #(195 1)
426 (sb-int:character-decoding-error-octets e
)))
429 (with-test (:name
:stream-to-c-string-decoding-restart-leakage
)
430 ;; Restarts for stream decoding errors didn't use to be associated with
431 ;; their conditions, so they could get confused with c-string decoding errors.
432 (assert (eq :nesting-ok
434 (handler-bind ((sb-int:character-decoding-error
435 (lambda (stream-condition)
436 (declare (ignore stream-condition
))
437 (handler-bind ((sb-int:character-decoding-error
438 (lambda (c-string-condition)
441 'sb-impl
::input-replacement
445 (let ((c-string (coerce #(70 195 1 182 195 182 0)
446 '(vector (unsigned-byte 8)))))
447 (sb-sys:with-pinned-objects
(c-string)
448 (sb-alien::c-string-to-string
449 (sb-sys:vector-sap c-string
)
450 :utf-8
'character
)))))))
451 (let ((namestring "alien.impure.tmp"))
454 (with-open-file (f namestring
455 :element-type
'(unsigned-byte 8)
457 :if-exists
:supersede
)
458 (dolist (b '(70 195 1 182 195 182 0))
460 (with-open-file (f namestring
461 :external-format
:utf-8
)
463 (delete-file namestring
))))))))
465 ;; Previously, the error signaled by (MACROEXPANDing the) redefinition
466 ;; of an alien structure itself signaled an error. Ensure that the
467 ;; error is signaled and prints properly.
468 (sb-alien:define-alien-type nil
469 (sb-alien:struct alien-structure-redefinition
(bar sb-alien
:int
)))
471 (with-test (:name
(:alien-structure-redefinition
:condition-printable
))
474 '(sb-alien:define-alien-type nil
475 (sb-alien:struct alien-structure-redefinition
(bar sb-alien
:c-string
))))
477 (princ-to-string condition
))
478 (:no-error
(&rest values
)
479 (declare (ignore values
))
480 (error "~@<Alien structure type redefinition failed to signal an ~
484 (with-test (:name
(:64-bit-return-truncation
))
485 (with-open-file (stream *load-truename
*)
486 (file-position stream
4294967310)
487 (assert (= 4294967310 (file-position stream
)))))
489 (with-test (:name
:stack-misalignment
)
490 (locally (declare (optimize (debug 2)))
492 (declare (optimize speed
))
493 (sb-ext:get-time-of-day
)))
494 (assert (equal (multiple-value-list
495 (multiple-value-prog1
496 (apply #'values
(list 1))
500 ;; Parse (ENUM COLOR)
501 (sb-alien-internals:parse-alien-type
'(enum color red blue black green
) nil
)
502 ;; Now reparse it as a different type
503 (with-test (:name
:change-enum-type
)
504 (handler-bind ((error #'continue
))
505 (sb-alien-internals:parse-alien-type
'(enum color yellow ochre
) nil
)))
507 (with-test (:name
:note-local-alien-type
)
508 (let ((type (sb-alien::make-local-alien-info
:type
509 (sb-alien-internals:parse-alien-type
'c-string nil
))))
510 (checked-compile-and-assert ()
512 (let ((alien (sb-alien-internals:make-local-alien
',type
)))
513 (sb-alien-internals:note-local-alien-type
',type alien
)
520 (with-test (:name
:memoize-coerce-to-interpreted-fun
)
521 (let* ((form1 '(lambda (x) x
))
522 (form2 (copy-tree form1
)))
523 (assert (eq (sb-alien::coerce-to-interpreted-function form1
)
524 (sb-alien::coerce-to-interpreted-function form2
)))))