1.0.5.6: compare-and-swap / instance-set-conditional refactoring

[sbcl.git] / src / code / late-extensions.lisp

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index a841f90..52b45c6 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -35,3 +35,54 @@
 ;;;      ;;     be doing him a favor by printing the object here.
 ;;;      ;; -- WHN 2002-10-19
 ;;;      (error "can't calculate length of cyclic list")))
+
+;;; This is used in constructing arg lists for debugger printing,
+;;; and when needing to print unbound slots in PCL.
+(defstruct (unprintable-object
+            (:constructor make-unprintable-object (string))
+            (:print-object (lambda (x s)
+                             (print-unreadable-object (x s)
+                               (write-string (unprintable-object-string x) s))))
+            (:copier nil))
+  string)
+
+;;; Used internally, but it would be nice to provide something
+;;; like this for users as well.
+#!+sb-thread
+(defmacro define-structure-slot-compare-and-swap
+    (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (type (when slotd (dsd-type slotd)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    (unless (eq t (dsd-raw-type slotd))
+      (error "Cannot define compare-and-swap on a raw slot."))
+    (when (dsd-read-only slotd)
+      (error "Cannot define compare-and-swap on a read-only slot."))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance old new)
+         (declare (type ,structure instance)
+                  (type ,type old new))
+         (%instance-compare-and-swap instance ,index old new)))))
+
+;;; Ditto
+#!+sb-thread
+(defmacro define-structure-slot-addressor (name &key structure slot)
+  (let* ((dd (find-defstruct-description structure t))
+         (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
+         (index (when slotd (dsd-index slotd))))
+    (unless index
+      (error "Slot ~S not found in ~S." slot structure))
+    `(progn
+       (declaim (inline ,name))
+       (defun ,name (instance)
+         (declare (type ,structure instance) (optimize speed))
+         (sb!ext:truly-the
+          sb!vm:word
+          (+ (sb!kernel:get-lisp-obj-address instance)
+             (- (* ,(+ sb!vm:instance-slots-offset index) sb!vm:n-word-bytes)
+                sb!vm:instance-pointer-lowtag)))))))
+