tests/typecase-cache.pure.lisp

   1 (unless (cl:gethash 'sb-c:jump-table sb-c::*backend-template-names*)
   2   (invoke-restart 'run-tests::skip-file))
   3
   4 (defstruct animal)
   5 (defstruct (goat (:include animal)))
   6 (defstruct (kid (:include goat)))
   7 (defstruct fruit)
   8 (defstruct (tree (:copier nil)))
   9 (defstruct (apple (:include fruit)))
  10 (defstruct (pair (:include fruit)))
  11 (defstruct (kons (:constructor kons (kar kdr))) kar kdr)
  12 (defstruct (pear (:include kons)))
  13 (defstruct (peach (:include apple)))
  14
  15 ;; TODO: this typecase is still suboptimal because after we've looked up
  16 ;; the relevant clause index, the answer should just be a constant.
  17 ;; I thought it already did that but I guess not?
  18 (defun f (x)
  19   (typecase x
  20     (apple 'computer)
  21     (fruit 'jam)
  22     (pear 'pair)
  23     (tree 3)
  24     ((or hash-table kid) 'peach)
  25     (kons 'pear)
  26     ((or peach pathname) 'yup)))
  27
  28 (compile 'f)
  29 (defstruct (macintosh (:include apple)))
  30 (defstruct (mulberry (:include tree)))
  31
  32 (with-test (:name :cached-typecase)
  33   (assert (eq (f (make-mulberry)) 3))
  34   (assert (eq (f (make-macintosh)) 'computer))
  35   (assert (eq (f #p"file.name") 'yup)))
  36
  37 (defvar *cell*  (car (ctu:find-code-constants #'f :type '(cons sb-pcl::cache))))
  38 (assert (sb-pcl::cache-p (car *cell*)))
  39
  40 (dotimes (i 100)
  41   (let ((form `(defstruct (,(intern (format nil "TUR~D" i)) (:Include fruit)))))
  42     (eval form)
  43     (assert (eq (f (funcall (intern (format nil "MAKE-TUR~D" i)))) 'jam))))
  44 (with-test (:name :expand-cache)
  45   (assert (>= (sb-pcl::cache-statistics (car *cell*)) 100)))