-;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; &KEY-argument-list-style list of alternating keywords and
-;;; arbitrary values, return a new &KEY-argument-list-style list with
-;;; all substitutions applied to it.
-;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if
-;;; efficiency mattered, why would we be using &KEY arguments at
-;;; all, much less renaming &KEY arguments?)
-;;;
-;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-key-args (rename-list key-args)
- (declare (type list rename-list key-args))
- ;; Walk through RENAME-LIST modifying RESULT as per each element in
- ;; RENAME-LIST.
- (do ((result (copy-list key-args))) ; may be modified below
- ((null rename-list) result)
- (destructuring-bind (old new) (pop rename-list)
- ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
- (declare (type symbol old new))
- ;; Walk through RESULT renaming any OLD key argument to NEW.
- (do ((in-result result (cddr in-result)))
- ((null in-result))
- (declare (type list in-result))
- (when (eq (car in-result) old)
- (setf (car in-result) new))))))
+(defmacro compare-and-swap (place old new)
+ "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 ,new))
+ (symbol-value
+ `(%compare-and-swap-symbol-value (the symbol ,@args) ,old ,new))
+ (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))))))))