X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Finit.lisp;h=5b6d913adda85a230046c0794f360557f4d116da;hb=e57523089c7ad0ce2c874c03ecfe721d299efbfb;hp=a73f35326cd4027de5b8134971bed38175dabc3c;hpb=cea2946076e0dac11eea1c95158e5e2326455dd8;p=sbcl.git

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index a73f353..5b6d913 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -60,6 +60,38 @@
   (apply #'shared-initialize instance nil initargs)
   instance)
 
+(defglobal **typecheck-cache** (make-hash-table :test #'equal))
+
+(defun generate-slotd-typecheck (slotd)
+  (let ((type (slot-definition-type slotd)))
+    (values
+     (when (and (neq t type) (safe-p (slot-definition-class slotd)))
+       (with-locked-system-table (**typecheck-cache**)
+         (or (gethash type **typecheck-cache**)
+             (setf (gethash type **typecheck-cache**)
+                   (handler-bind (((or style-warning compiler-note)
+                                   #'muffle-warning))
+                     (funcall (compile
+                               nil
+                               `(lambda ()
+                                  (declare (optimize (sb-c:store-coverage-data 0)
+                                                     (sb-c::type-check 3)
+                                                     (sb-c::verify-arg-count 0)))
+                                  (named-lambda (slot-typecheck ,type) (value)
+                                    (the ,type value))))))))))
+     type)))
+
+(defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
+  (setf (slot-definition-info slotd)
+        (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+          (make-slot-info :slotd slotd
+                          :typecheck typecheck))))
+
+;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
+(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
+  (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+    (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
+
 (defmethod update-instance-for-different-class
     ((previous standard-object) (current standard-object) &rest initargs)
   ;; First we must compute the newly added slots. The spec defines