0.9.18.38:

[sbcl.git] / src / pcl / slots.lisp

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 2e3d358..aade5b2 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -103,9 +103,23 @@
         (setf (slot-value-using-class class object slot-definition)
               new-value))))
 
-(define-compiler-macro set-slot-value (&whole form object slot-name new-value)
+;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
+;;; check types when writing to slots:
+;;;   * Doesn't have an optimizing compiler-macro
+;;;   * Isn't special-cased in WALK-METHOD-LAMBDA
+(defun safe-set-slot-value (object slot-name new-value)
+  (set-slot-value object slot-name new-value))
+
+(define-compiler-macro set-slot-value (&whole form object slot-name new-value
+                                              &environment env)
   (if (and (constantp slot-name)
-           (interned-symbol-p (constant-form-value slot-name)))
+           (interned-symbol-p (constant-form-value slot-name))
+           ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
+           ;; code, since it'll use the global automatically generated
+           ;; accessor, which won't do typechecking. (SLOT-OBJECT
+           ;; won't have been compiled with SAFETY 3, so SAFE-P will
+           ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION).
+           (not (safe-code-p env)))
       `(accessor-set-slot-value ,object ,slot-name ,new-value)
       form))
 
@@ -136,9 +150,12 @@
   (let ((class (class-of object)))
     (not (null (find-slot-definition class slot-name)))))
 
+(defvar *unbound-slot-value-marker* (make-unprintable-object "unbound slot"))
+
 ;;; This isn't documented, but is used within PCL in a number of print
 ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
-(defun slot-value-or-default (object slot-name &optional (default "unbound"))
+(defun slot-value-or-default (object slot-name &optional
+                              (default *unbound-slot-value-marker*))
   (if (slot-boundp object slot-name)
       (slot-value object slot-name)
       default))
@@ -179,22 +196,29 @@
                       (object standard-object)
                       (slotd standard-effective-slot-definition))
   (check-obsolete-instance object)
-  (let ((location (slot-definition-location slotd)))
-    (typecase location
-      (fixnum
-       (cond ((std-instance-p object)
-              (setf (clos-slots-ref (std-instance-slots object) location)
-                    new-value))
-             ((fsc-instance-p object)
-              (setf (clos-slots-ref (fsc-instance-slots object) location)
-                    new-value))
-             (t (bug "unrecognized instance type in ~S"
-                     '(setf slot-value-using-class)))))
-      (cons
-       (setf (cdr location) new-value))
-      (t
-       (instance-structure-protocol-error slotd
-                                          '(setf slot-value-using-class))))))
+  (let ((location (slot-definition-location slotd))
+        (type-check-function
+         (when (safe-p class)
+           (slot-definition-type-check-function slotd))))
+    (flet ((check (new-value)
+             (when type-check-function
+               (funcall (the function type-check-function) new-value))
+             new-value))
+      (typecase location
+        (fixnum
+         (cond ((std-instance-p object)
+                (setf (clos-slots-ref (std-instance-slots object) location)
+                      (check new-value)))
+               ((fsc-instance-p object)
+                (setf (clos-slots-ref (fsc-instance-slots object) location)
+                      (check new-value)))
+                (t (bug "unrecognized instance type in ~S"
+                        '(setf slot-value-using-class)))))
+        (cons
+         (setf (cdr location) (check new-value)))
+        (t
+         (instance-structure-protocol-error
+          slotd '(setf slot-value-using-class)))))))
 
 (defmethod slot-boundp-using-class
            ((class std-class)
@@ -318,7 +342,16 @@
          instance))
 
 (defmethod slot-unbound ((class t) instance slot-name)
-  (error 'unbound-slot :name slot-name :instance instance))
+  (restart-case
+      (error 'unbound-slot :name slot-name :instance instance)
+    (use-value (v)
+      :report "Return a value as the slot-value."
+      :interactive read-evaluated-form
+      v)
+    (store-value (v)
+      :report "Store and return a value as the slot-value."
+      :interactive read-evaluated-form
+      (setf (slot-value instance slot-name) v))))
 
 (defun slot-unbound-internal (instance position)
   (values