- (when variable-length-p
- (error "No more slots can follow a :rest-p slot."))
- (destructuring-bind
- (slot-name &rest options
- &key docs rest-p (length (if rest-p 0 1))
- ((:type slot-type) t) init
- (ref-known nil ref-known-p) ref-trans
- (set-known nil set-known-p) set-trans
- &allow-other-keys)
- (if (atom spec) (list spec) spec)
- (slots (make-slot slot-name docs rest-p offset length
- (remove-keywords options
- '(:docs :rest-p :length))))
- (let ((offset-sym (symbolicate name "-" slot-name
- (if rest-p "-OFFSET" "-SLOT"))))
- (constants `(def!constant ,offset-sym ,offset
- ,@(when docs (list docs))))
- (exports offset-sym))
- (when ref-trans
- (when ref-known-p
- (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
- (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
- (when set-trans
- (when set-known-p
- (forms `(defknown ,set-trans
- ,(if (listp set-trans)
- (list slot-type type)
- (list type slot-type))
- ,slot-type
- ,set-known)))
- (forms `(def-setter ,set-trans ,offset ,lowtag)))
- (when init
- (inits (cons init offset)))
- (when rest-p
- (setf variable-length-p t))
- (incf offset length)))
+ (when variable-length-p
+ (error "No more slots can follow a :rest-p slot."))
+ (destructuring-bind
+ (slot-name &rest options
+ &key docs rest-p (length (if rest-p 0 1))
+ ((:type slot-type) t) init
+ (ref-known nil ref-known-p) ref-trans
+ (set-known nil set-known-p) set-trans
+ cas-trans
+ &allow-other-keys)
+ (if (atom spec) (list spec) spec)
+ (slots (make-slot slot-name docs rest-p offset
+ (remove-keywords options
+ '(:docs :rest-p :length))))
+ (let ((offset-sym (symbolicate name "-" slot-name
+ (if rest-p "-OFFSET" "-SLOT"))))
+ (constants `(def!constant ,offset-sym ,offset
+ ,@(when docs (list docs))))
+ (exports offset-sym))
+ (when ref-trans
+ (when ref-known-p
+ (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
+ (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
+ (when set-trans
+ (when set-known-p
+ (forms `(defknown ,set-trans
+ ,(if (listp set-trans)
+ (list slot-type type)
+ (list type slot-type))
+ ,slot-type
+ ,set-known)))
+ (forms `(def-setter ,set-trans ,offset ,lowtag)))
+ (when cas-trans
+ (when rest-p
+ (error ":REST-P and :CAS-TRANS incompatible."))
+ (forms
+ `(progn
+ (defknown ,cas-trans (,type ,slot-type ,slot-type)
+ ,slot-type (unsafe))
+ #!+compare-and-swap-vops
+ (def-casser ,cas-trans ,offset ,lowtag))))
+ (when init
+ (inits (cons init offset)))
+ (when rest-p
+ (setf variable-length-p t))
+ (incf offset length)))