mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
53 lines
1.8 KiB
Common Lisp
53 lines
1.8 KiB
Common Lisp
(unless (cl:gethash 'sb-c:jump-table sb-c::*backend-template-names*)
|
|
(invoke-restart 'run-tests::skip-file))
|
|
|
|
(defstruct animal)
|
|
(defstruct (goat (:include animal)))
|
|
(defstruct (kid (:include goat)))
|
|
(defstruct fruit)
|
|
(defstruct (tree (:copier nil)))
|
|
(defstruct (apple (:include fruit)))
|
|
(defstruct (pair (:include fruit)))
|
|
(defstruct (kons (:constructor kons (kar kdr))) kar kdr)
|
|
(defstruct (pear (:include kons)))
|
|
(defstruct (peach (:include apple)))
|
|
|
|
;; TODO: this typecase is still suboptimal because after we've looked up
|
|
;; the relevant clause index, the answer should just be a constant.
|
|
;; I thought it already did that but I guess not?
|
|
(defun f (x)
|
|
(typecase x
|
|
(apple 'computer)
|
|
(fruit 'jam)
|
|
(pear 'pair)
|
|
(tree 3)
|
|
((or hash-table kid) 'peach)
|
|
(kons 'pear)
|
|
((or peach pathname) 'yup)))
|
|
|
|
(compile 'f)
|
|
(defstruct (macintosh (:include apple)))
|
|
(defstruct (mulberry (:include tree)))
|
|
|
|
(with-test (:name :cached-typecase)
|
|
(assert (eq (f (make-mulberry)) 3))
|
|
(assert (eq (f (make-macintosh)) 'computer))
|
|
(assert (eq (f #p"file.name") 'yup)))
|
|
|
|
(defvar *cell* (car (ctu:find-code-constants #'f :type '(cons sb-pcl::cache))))
|
|
(assert (sb-pcl::cache-p (car *cell*)))
|
|
|
|
(dotimes (i 100)
|
|
(let ((form `(defstruct (,(intern (format nil "TUR~D" i)) (:Include fruit)))))
|
|
(eval form)
|
|
(assert (eq (f (funcall (intern (format nil "MAKE-TUR~D" i)))) 'jam))))
|
|
(with-test (:name :expand-cache)
|
|
(let* ((cache (car *cell*))
|
|
(as-string (write-to-string cache :escape t))
|
|
(expect "#<SB-PCL::CACHE 1 key, value, "))
|
|
(assert (string= as-string expect :end1 (length expect)))
|
|
(multiple-value-bind (lines endpos)
|
|
(parse-integer as-string :start (length expect) :junk-allowed t)
|
|
(assert (char= (char as-string endpos) #\/))
|
|
(assert (>= lines 100)))))
|