1 ;;;; Interaction of SB-MOP:FUNCALLABLE-STANDARD-OBJECT with COERCE
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 (defun unoptimized/symbol
()
16 (coerce x
(opaque-identity 'sb-mop
:funcallable-standard-object
))))
17 (defun unoptimized/class
()
19 (coerce x
(opaque-identity (find-class 'sb-mop
:funcallable-standard-object
)))))
20 (defun optimized/symbol
()
21 (compile nil
`(lambda (x) (coerce x
'sb-mop
:funcallable-standard-object
))))
22 (defun optimized/class
()
23 (compile nil
`(lambda (x) (coerce x
',(find-class 'sb-mop
:funcallable-standard-object
)))))
25 (with-test (:name
(coerce standard-object
))
26 (let ((o (make-instance 'standard-object
)))
27 (assert-error (funcall (unoptimized/symbol
) o
) type-error
)
28 (assert-error (funcall (unoptimized/class
) o
) type-error
)
29 (assert-error (funcall (optimized/symbol
) o
) type-error
)
30 (assert-error (funcall (optimized/class
) o
) type-error
)))
32 (with-test (:name
(coerce :funcallable-standard-object
))
33 (let ((o (make-instance 'sb-mop
:funcallable-standard-object
)))
34 (assert (eql (funcall (unoptimized/symbol
) o
) o
))
35 (assert (eql (funcall (unoptimized/class
) o
) o
))
36 (assert (eql (funcall (optimized/symbol
) o
) o
))
37 (assert (eql(funcall (optimized/class
) o
) o
))))
39 (with-test (:name
(coerce symbol
))
41 (assert-error (funcall (unoptimized/symbol
) o
) type-error
)
42 (assert-error (funcall (unoptimized/class
) o
) type-error
)
43 (assert-error (funcall (optimized/symbol
) o
) type-error
)
44 (assert-error (funcall (optimized/class
) o
) type-error
)))
46 (with-test (:name
(coerce lambda
))
47 (let ((o '(lambda (x) (1+ x
))))
48 (assert-error (funcall (unoptimized/symbol
) o
) type-error
)
49 (assert-error (funcall (unoptimized/class
) o
) type-error
)
50 (assert-error (funcall (optimized/symbol
) o
) type-error
)
51 (assert-error (funcall (optimized/class
) o
) type-error
)))