X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffixup.lisp;h=3ba115358b70ee12dcb4d959b30c8bba503d5b8b;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=e3d7f0ad129d4525afe8ce844e69d051e21741f8;hpb=da304936655b6690b4ddf15fb2936fe3d219f2ac;p=sbcl.git

diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index e3d7f0a..3ba1153 100644
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -26,12 +26,65 @@
 (!fix-early-generic-functions)
 (!fix-ensure-accessor-specializers)
 (compute-standard-slot-locations)
-(dolist (s '(condition structure-object))
-  (dohash (k v (classoid-subclasses (find-classoid s)))
+(dolist (s '(condition function structure-object))
+  (dohash ((k v) (classoid-subclasses (find-classoid s)))
     (find-class (classoid-name k))))
-(setq *boot-state* 'complete)
+(setq **boot-state** 'complete)
 
 (defun print-std-instance (instance stream depth)
   (declare (ignore depth))
   (print-object instance stream))
 
+(setf (compiler-macro-function 'slot-value) nil)
+(setf (compiler-macro-function 'set-slot-value) nil)
+
+(in-package "SB-C")
+
+(defknown slot-value (t symbol) t (any))
+(defknown (slot-boundp slot-exists-p) (t symbol) boolean)
+(defknown sb-pcl::set-slot-value (t symbol t) t (any))
+
+(defknown find-class (symbol &optional t lexenv-designator)
+  (or class null))
+(defknown class-of (t) class (flushable))
+(defknown class-name (class) symbol (flushable))
+
+(deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
+                          :node node)
+  (let ((c-slot-name (lvar-value slot-name)))
+    (if (sb-pcl::interned-symbol-p c-slot-name)
+        (let* ((type (lvar-type object))
+               (dd (when (structure-classoid-p type)
+                     (find-defstruct-description
+                      (sb-kernel::structure-classoid-name type))))
+               (dsd (when dd
+                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
+          (cond (dsd
+                 `(,(dsd-accessor-name dsd) object))
+                (t
+                 (delay-ir1-transform node :constraint)
+                 `(sb-pcl::accessor-slot-value object ',c-slot-name))))
+        (give-up-ir1-transform "slot name is not an interned symbol"))))
+
+(deftransform sb-pcl::set-slot-value ((object slot-name new-value)
+                                      (t (constant-arg symbol) t)
+                                      * :node node)
+  (let ((c-slot-name (lvar-value slot-name)))
+    (if (sb-pcl::interned-symbol-p c-slot-name)
+        (let* ((type (lvar-type object))
+               (dd (when (structure-classoid-p type)
+                     (find-defstruct-description
+                      (sb-kernel::structure-classoid-name type))))
+               (dsd (when dd
+                      (find c-slot-name (dd-slots dd) :key #'dsd-name))))
+          (cond (dsd
+                 `(setf (,(dsd-accessor-name dsd) object) new-value))
+                ((policy node (= safety 3))
+                 ;; Safe code wants to check the type, and the global
+                 ;; accessor won't do that. Also see the comment in the
+                 ;; compiler-macro.
+                 (give-up-ir1-transform "cannot use optimized accessor in safe code"))
+                (t
+                 (delay-ir1-transform node :constraint)
+                 `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
+        (give-up-ir1-transform "slot name is not an interned symbol"))))