X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-extensions.lisp;h=59a2fd6770702677c7310823c94d1caa2fdc60fd;hb=fb2d28ba0ccab2afb9e68b4de722ba2179bcea8e;hp=45fe8b4d6e0a448c8c5c2d3a7cf10caf75be4d1e;hpb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;p=sbcl.git

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 45fe8b4..59a2fd6 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -73,99 +73,7 @@
                    sb!vm:n-word-bytes)
                 sb!vm:instance-pointer-lowtag)))))))
 
-(defmacro compare-and-swap (place old new &environment env)
-  "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
-Two values are considered to match if they are EQ. Returns the previous value
-of PLACE: if the returned value is EQ to OLD, the swap was carried out.
-
-PLACE must be an accessor form whose CAR is one of the following:
-
- CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
-
-or the name of a DEFSTRUCT created accessor for a slot whose declared type is
-either FIXNUM or T. Results are unspecified if the slot has a declared type
-other then FIXNUM or T.
-
-EXPERIMENTAL: Interface subject to change."
-  (flet ((invalid-place ()
-           (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
-    (unless (consp place)
-      (invalid-place))
-  ;; FIXME: Not the nicest way to do this...
-  (destructuring-bind (op &rest args) place
-    (case op
-      ((car first)
-       `(%compare-and-swap-car (the cons ,@args) ,old ,new))
-      ((cdr rest)
-       `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
-      (symbol-plist
-       `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
-      (symbol-value
-       (destructuring-bind (name) args
-         (flet ((slow (symbol)
-                  (with-unique-names (n-symbol n-old n-new)
-                    `(let ((,n-symbol ,symbol)
-                           (,n-old ,old)
-                           (,n-new ,new))
-                       (declare (symbol ,n-symbol))
-                       (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new)
-                       (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
-           (if (sb!xc:constantp name env)
-               (let ((cname (constant-form-value name env)))
-                 (if (eq :special (info :variable :kind cname))
-                     ;; Since we know the symbol is a special, we can just generate
-                     ;; the type check.
-                     `(%compare-and-swap-symbol-value
-                       ',cname ,old (the ,(info :variable :type cname) ,new))
-                     (slow (list 'quote cname))))
-               (slow name)))))
-      (svref
-       (let ((vector (car args))
-             (index (cadr args)))
-         (unless (and vector index (not (cddr args)))
-           (invalid-place))
-         (with-unique-names (v)
-           `(let ((,v ,vector))
-              (declare (simple-vector ,v))
-              (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
-      (t
-       (let ((dd (info :function :structure-accessor op)))
-         (if dd
-             (let* ((structure (dd-name dd))
-                    (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
-                    (index (dsd-index slotd))
-                    (type (dsd-type slotd)))
-               (unless (eq t (dsd-raw-type slotd))
-                 (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
-                        place))
-               (when (dsd-read-only slotd)
-                 (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
-                        place))
-               `(truly-the (values ,type &optional)
-                           (%compare-and-swap-instance-ref (the ,structure ,@args)
-                                                           ,index
-                                                           (the ,type ,old) (the ,type ,new))))
-             (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
-
-(macrolet ((def (name lambda-list ref &optional set)
-             #!+compare-and-swap-vops
-             (declare (ignore ref set))
-             `(defun ,name (,@lambda-list old new)
-                #!+compare-and-swap-vops
-                (,name ,@lambda-list old new)
-                #!-compare-and-swap-vops
-                (let ((current (,ref ,@lambda-list)))
-                  (when (eq current old)
-                    ,(if set
-                         `(,set ,@lambda-list new)
-                         `(setf (,ref ,@lambda-list) new)))
-                  current))))
-  (def %compare-and-swap-car (cons) car)
-  (def %compare-and-swap-cdr (cons) cdr)
-  (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
-  (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
-  (def %compare-and-swap-symbol-value (symbol) symbol-value)
-  (def %compare-and-swap-svref (vector index) svref))
+;;;; ATOMIC-INCF and ATOMIC-DECF
 
 (defun expand-atomic-frob (name place diff)
   (flet ((invalid-place ()