mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
73 lines
3 KiB
Common Lisp
73 lines
3 KiB
Common Lisp
;;;; tests for renameable closures
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
(defun makec1 (a) (lambda () "doc" (values a)))
|
|
(defun makec2 (a b) (lambda () "doc" (values a b)))
|
|
(compile 'makec1)
|
|
(compile 'makec2)
|
|
|
|
(with-test (:name :closure-renaming)
|
|
(let ((c1 (makec1 :a))) ; C1 has a padding slot
|
|
(assert (eq (sb-int:set-closure-name c1 t 'foo) c1)) ; T = permit copy
|
|
;; But it's not copied, because it had a slot available.
|
|
(assert (eq (sb-kernel:%fun-name c1) 'foo))
|
|
(assert (zerop (hash-table-count sb-impl::**closure-extra-values**)))
|
|
|
|
(assert (eq (sb-int:set-closure-name c1 nil 'foo2) c1)) ; NIL = don't permit copy
|
|
;; And again was not copied
|
|
(assert (eq (sb-kernel:%fun-name c1) 'foo2))
|
|
(assert (zerop (hash-table-count sb-impl::**closure-extra-values**)))
|
|
|
|
(let* ((c2 (makec2 :a :b)) ; C2 doesn't have a padding slot
|
|
(c2* (sb-int:set-closure-name c2 t 'bar)))
|
|
(assert (not (eq c2 c2*)))
|
|
(assert (eq (sb-kernel:%fun-name c2*) 'bar))
|
|
(assert (zerop (hash-table-count sb-impl::**closure-extra-values**)))
|
|
|
|
;; C2* has a padding slot
|
|
(assert (eq (sb-int:set-closure-name c2* t 'baz) c2*))
|
|
(assert (eq (sb-kernel:%fun-name c2*) 'baz))
|
|
|
|
;; Don't permit copy
|
|
(assert (eq (sb-int:set-closure-name c2 nil 'fred) c2))
|
|
(assert (eq (sb-kernel:%fun-name c2) 'fred))
|
|
(assert (plusp (hash-table-count sb-impl::**closure-extra-values**)))
|
|
)))
|
|
|
|
(with-test (:name :closure-docstrings)
|
|
(dolist (name `("afun" afun (afun) (afun . "guy") (afun . guy) (afun guy)
|
|
,sb-pcl:+slot-unbound+ nil))
|
|
(dolist (doc `("what's up" nil ,sb-pcl:+slot-unbound+))
|
|
(dolist (closure (list (makec1 :a)
|
|
(makec2 :a :b)))
|
|
(sb-impl::set-closure-extra-values
|
|
closure nil (sb-impl::pack-closure-extra-values name doc))
|
|
(multiple-value-bind (stored-name stored-doc)
|
|
(sb-impl::closure-extra-values closure)
|
|
(assert (eq stored-name name))
|
|
(assert (eq stored-doc doc)))
|
|
(assert (string= (documentation closure t)
|
|
(if (eq doc sb-pcl:+slot-unbound+) "doc" doc)))))))
|
|
|
|
(with-test (:name :no-funcall-of-extended-name)
|
|
(multiple-value-bind (fun warnp errorp)
|
|
(checked-compile '(lambda (x y) (funcall '(setf foo) x y))
|
|
:allow-warnings t)
|
|
(assert (and warnp errorp))
|
|
(assert-error (funcall fun nil 1) type-error))
|
|
(multiple-value-bind (fun warnp errorp)
|
|
(checked-compile '(lambda (x y) (multiple-value-call '(setf foo) x (floor y 2)))
|
|
:allow-warnings t)
|
|
(assert (and warnp errorp))
|
|
(assert-error (funcall fun nil 1) type-error)))
|