-;;; KLUDGE: This is a wrapper around stale code for working with floating point
-;;; infinities. I believe that I will eventually eliminate floating point
-;;; infinities from the code, since they're a pain to cross-compile, since they
-;;; significantly increase the number of conditions which need to be tested in
-;;; numeric functions, and since the benefits which they provide (which are
-;;; admittedly significant) are unfortunately not portable. I haven't actually
-;;; done the dirty deed yet, though, and until then, I've wrapped various
-;;; infinity-returning forms in this macro. -- WHN 1999
-(defmacro infinite (x)
- (declare (ignorable x))
- #!-sb-infinities '(error 'floating-point-overflow)
- #!+sb-infinities x)
+(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 if 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 SYMBOL-VALUE of ~S" ,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))))))))