tests/fun-names.pure.lisp

   1 ;;;; tests for renameable closures
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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
   8 ;;;; from CMU CL.
   9 ;;;;
  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.
  13
  14 (defun makec1 (a) (lambda () (values a)))
  15 (defun makec2 (a b) (lambda () (values a b)))
  16 (compile 'makec1)
  17 (compile 'makec2)
  18
  19 (with-test (:name :closure-renaming)
  20   (let ((c1 (makec1 :a))) ; C1 has a padding slot
  21     (assert (eq (sb-int:set-closure-name c1 t 'foo) c1)) ; T = permit copy
  22     ;; But it's not copied, because it had a slot available.
  23     (assert (eq (sb-impl::closure-name c1) 'foo))
  24     (assert (zerop (hash-table-count sb-impl::**closure-names**)))
  25
  26     (assert (eq (sb-int:set-closure-name c1 nil 'foo2) c1)) ; NIL = don't permit copy
  27     ;; And again was not copied
  28     (assert (eq (sb-impl::closure-name c1) 'foo2))
  29     (assert (zerop (hash-table-count sb-impl::**closure-names**)))
  30
  31   (let* ((c2 (makec2 :a :b)) ; C2 doesn't have a padding slot
  32          (c2* (sb-int:set-closure-name c2 t 'bar)))
  33     (assert (not (eq c2 c2*)))
  34     (assert (eq (sb-impl::closure-name c2*) 'bar))
  35     (assert (zerop (hash-table-count sb-impl::**closure-names**)))
  36
  37     ;; C2* has a padding slot
  38     (assert (eq (sb-int:set-closure-name c2* t 'baz) c2*))
  39     (assert (eq (sb-impl::closure-name c2*) 'baz))
  40
  41     ;; Don't permit copy
  42     (assert (eq (sb-int:set-closure-name c2 nil 'fred) c2))
  43     (assert (eq (sb-impl::closure-name c2) 'fred))
  44     (assert (plusp (hash-table-count sb-impl::**closure-names**)))
  45     )))
  46