mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
ba08d271de
Some checks failed
CL-host / ecl (push) Has been cancelled
CL-host / clisp (push) Has been cancelled
CL-host / ccl (push) Has been cancelled
CL-host / cmucl (push) Has been cancelled
CL-host / sbcl (push) Has been cancelled
Linux arm / build (push) Has been cancelled
Linux arm64 / build () (push) Has been cancelled
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call) (push) Has been cancelled
Linux qemu / build (ppc64le) (push) Has been cancelled
Linux qemu / build (riscv64) (push) Has been cancelled
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Has been cancelled
Linux / build (x86, --with-sb-thread, ) (push) Has been cancelled
Linux / build (x86, --without-sb-thread, ) (push) Has been cancelled
Linux / build (x86, --without-sb-unicode, ) (push) Has been cancelled
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Has been cancelled
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Has been cancelled
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call, sse4) (push) Has been cancelled
Linux / build (x86-64, --with-sb-thread, ) (push) Has been cancelled
Linux / build (x86-64, --without-sb-thread, ) (push) Has been cancelled
Linux / build (x86-64, --without-sb-unicode, ) (push) Has been cancelled
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Has been cancelled
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call) (push) Has been cancelled
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Has been cancelled
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Has been cancelled
CL-host / compare-xc-host-fasls (cmucl, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (ccl, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (clisp, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (self, false) (push) Has been cancelled
Fixes lp#2160429
82 lines
3.2 KiB
Common Lisp
82 lines
3.2 KiB
Common Lisp
(defstruct root)
|
|
(defstruct (subtype1 (:include root)))
|
|
(defstruct (subtype2 (:include root)))
|
|
|
|
(defun swap-subtype (x)
|
|
(declare (root x))
|
|
(cond ((subtype1-p x)
|
|
(setf (sb-kernel:%instance-layout x) #.(sb-kernel:find-layout 'subtype2)))
|
|
((subtype2-p x)
|
|
(setf (sb-kernel:%instance-layout x) #.(sb-kernel:find-layout 'subtype1)))))
|
|
|
|
(defun way1 (a b) (and (root-p a) (root-p b) (eq (type-of a) (type-of b)))) ; transforms
|
|
(defun way2.1 (a b) (declare (root a)) (eq (type-of a) (type-of b))) ; transforms
|
|
(defun way2.2 (a b) (eq (type-of (the root a)) (type-of b))) ; transforms
|
|
(defun way2.3 (a b) (eq (class-of (the root a)) (class-of b))) ; transforms
|
|
(defun way3.1 (a b) (declare (root b)) (eq (type-of a) (type-of b))) ; transforms
|
|
(defun way3.2 (a b) (eq (type-of a) (type-of (the root b)))) ; does not transform but should
|
|
(defun way4 (a b) ; does not and should not transform
|
|
(and (root-p a)
|
|
(root-p b)
|
|
(eq (prog1 (type-of a) (swap-subtype a)) (type-of b))))
|
|
|
|
(with-test (:name :eq-type-of-type-of.1)
|
|
(compile 'way1)
|
|
(assert (way1 (make-root) (make-root)))
|
|
(assert (way1 (make-subtype1) (make-subtype1)))
|
|
(assert (not (way1 (make-subtype2) (make-root))))
|
|
(assert (not (way1 #p"a" #p"b"))))
|
|
|
|
(with-test (:name :eq-type-of-type-of.2)
|
|
(macrolet ((try (way)
|
|
`(progn
|
|
(compile ',way)
|
|
(assert (,way (make-root) (make-root)))
|
|
(assert (,way (make-subtype1) (make-subtype1)))
|
|
(assert (not (,way (make-subtype1) (make-root))))
|
|
(assert (not (,way (make-subtype1) #p"b"))) ; 2nd arg is arbitrary
|
|
(assert (not (,way (make-subtype1) #'car)))
|
|
(assert (not (,way (make-subtype1) 5))))))
|
|
(try way2.1)
|
|
(try way2.2)
|
|
(try way2.3)))
|
|
|
|
(with-test (:name :eq-type-of-type-of.3)
|
|
(macrolet ((try (way)
|
|
`(progn (compile ',way)
|
|
(assert (,way (make-root) (make-root)))
|
|
(assert (,way (make-subtype1) (make-subtype1)))
|
|
(assert (not (,way (make-subtype1) (make-root))))
|
|
(assert (not (,way #p"a" (make-subtype1)))) ; 1st arg is arbitrary
|
|
(assert (not (,way #'car (make-subtype1))))
|
|
(assert (not (,way 5 (make-subtype1)))))))
|
|
(try way3.1)
|
|
;; try (way3.2)
|
|
))
|
|
|
|
(with-test (:name :eq-type-of-type-of.4)
|
|
(compile 'way4)
|
|
(let ((x (make-subtype1))
|
|
(y (make-subtype2)))
|
|
;; the funky function changes the layout of X which means that if the test of its layout
|
|
;; were delayed until the EQ as the vop would do, it would incorrectly get T as the answer.
|
|
(assert (not (way4 x y)))
|
|
(assert (eq (sb-kernel:layout-of x) (sb-kernel:layout-of y)))))
|
|
|
|
(with-test (:name :or-complex-members)
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(typep x '(and number (not (eql #C(1 2d0))))))
|
|
((1) t)
|
|
((#C(1 2d0)) nil)
|
|
((#C(1 3d0)) t))
|
|
(checked-compile-and-assert
|
|
()
|
|
`(lambda (x)
|
|
(typep x '(or real (complex single-float) (complex rational) (eql #C(1 2d0)))))
|
|
((1) t)
|
|
((#C(1 2)) t)
|
|
((#C(1 3d0)) nil)
|
|
((#C(1 2d0)) t)))
|