Menu
▾
▴
[Sbcl-commits] 1.0.46.11: faster slot-accesses in the presence of SLOT-VALUE-USING-CLASS &co
|
From: Nikodemus S. <nik...@ra...> - 2011-02-20 11:49:13
|
1.0.46.11: faster slot-accesses in the presence of SLOT-VALUE-USING-CLASS &co
* Introducing SLOT-INFO: a structure we save into the each
EFFECTIVE-SLOT-DEFINITION object, which provides us with fast-accesses to
typecheck, reader, writer, and boundp functions for that slot. (These
functions already pre-exist, and currently live directly in the slot
definition objects.)
This replaces typecheckfuns in permutation vectors, and both the
typecheckfun and slotd in slot-tables.
Given this, when we run into SLOT-VALUE in a method body when there is an
applicable non-standard SLOT-VALUE-USING-CLASS, we don't have to punt to
the slow path, but can instead replace the SLOT-VALUE form with
`(funcall (slot-info-reader (svref .pv. (1+ ,pv-offset))) ,parameter)
which is pretty snappy as these things go. Analogously for SET-SLOT-VALUE,
and SLOT-BOUNDP.
* Previously slot typechecking functions were generated as part of the
DEFCLASS expansion and made part of DIRECT-SLOT-DEFINITION objects. This
was a bit wasteful, as (1) we don't need them for direct slot definitions,
and (2) we used to get a separate typechecking function for each slot in
each safe class, even if they all had the same type.
Now there's only one typechecking function per type, and that is saved only
in the SLOT-INFO structure of the relevant effective slot definitions.
* In a couple of places finalize the class a bit earlier if possible to have
a better idea of how to best implement slot
accesses. TRY-FINALIZE-INHERITANCE tries, but refuses if there are forward
referenced superclasses. CAN-OPTIMIZE-ACCESS will signal a compiler-note
about such cases.
* WRAPPER-INSTANCE-SLOTS-LAYOUT now also includes slot-types, and we consider
the instance to be obsoleted when slot-type changes. (This was a bug that
our previous type-check-function setup accidentally worked around.)
Detect slot-type violations while updating instances of safe classes.
Similarly for CHANGE-CLASS.
Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1881
diff -u -r1.1881 NEWS
--- NEWS 20 Feb 2011 10:48:32 -0000 1.1881
+++ NEWS 20 Feb 2011 11:13:05 -0000
@@ -4,6 +4,8 @@
* enhancement: redefinition warnings for macros from different
files. (lp#434657)
* enhancement: better MACHINE-VERSION on Darwin x86 and x86-64. (lp#668332)
* enhancement: (FORMAT "foo" ...) and similar signal a compile-time
warning. (lp#327223)
+ * optimization: slot accesses are faster in the presence of
SLOT-VALUE-USING-CLASS
+ and its compatriots.
* bug fix: SB-DEBUG:BACKTRACE-AS-LIST guards against potentially leaking
stack-allocated values out of their dynamic-extent. (lp#310175)
* bug fix: attempts to use SB-SPROF for wallclock profiling on threaded
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5195
diff -u -r1.5195 version.lisp-expr
--- version.lisp-expr 20 Feb 2011 10:51:39 -0000 1.5195
+++ version.lisp-expr 20 Feb 2011 11:13:06 -0000
@@ -20,4 +20,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.10"
+"1.0.46.11"
Index: src/pcl/braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.76
diff -u -r1.76 braid.lisp
--- src/pcl/braid.lisp 15 Sep 2009 11:07:39 -0000 1.76
+++ src/pcl/braid.lisp 20 Feb 2011 11:13:06 -0000
@@ -188,7 +188,10 @@
(when (typep wrapper 'wrapper)
(setf (wrapper-instance-slots-layout wrapper)
- (mapcar #'canonical-slot-name slots))
+ (mapcar (lambda (slotd)
+ ;; T is the slot-definition-type.
+ (cons (canonical-slot-name slotd) t))
+ slots))
(setf (wrapper-class-slots wrapper)
()))
@@ -367,19 +370,20 @@
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
(set-val '%type (or (get-val :type) t))
- (set-val '%type-check-function (get-val 'type-check-function))
(set-val '%documentation (or (get-val :documentation) ""))
(set-val '%class class)
(when effective-p
(set-val 'location index)
- (let ((fsc-p nil))
- (set-val 'reader-function (make-optimized-std-reader-method-function
- fsc-p nil slot-name index))
- (set-val 'writer-function (make-optimized-std-writer-method-function
- fsc-p nil slot-name index))
- (set-val 'boundp-function (make-optimized-std-boundp-method-function
- fsc-p nil slot-name index)))
- (set-val 'accessor-flags 7))
+ (set-val 'accessor-flags 7)
+ (set-val
+ 'info
+ (make-slot-info
+ :reader
+ (make-optimized-std-reader-method-function nil nil slot-name index)
+ :writer
+ (make-optimized-std-writer-method-function nil nil slot-name index)
+ :boundp
+ (make-optimized-std-boundp-method-function nil nil
slot-name index))))
(when (and (eq name 'standard-class)
(eq slot-name 'slots) effective-p)
(setq *the-eslotd-standard-class-slots* slotd))
@@ -545,11 +549,8 @@
(let ((accessor (structure-slotd-accessor-symbol slotd)))
`(:name ,(structure-slotd-name slotd)
:defstruct-accessor-symbol ,accessor
- ,@(when (fboundp accessor)
- `(:internal-reader-function
- ,(structure-slotd-reader-function slotd)
- :internal-writer-function
- ,(structure-slotd-writer-function name slotd)))
+ :internal-reader-function ,(structure-slotd-reader-function slotd)
+ :internal-writer-function
,(structure-slotd-writer-function name slotd)
:type ,(or (structure-slotd-type slotd) t)
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd)))))
Index: src/pcl/defclass.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defclass.lisp,v
retrieving revision 1.46
diff -u -r1.46 defclass.lisp
--- src/pcl/defclass.lisp 13 Sep 2010 11:04:01 -0000 1.46
+++ src/pcl/defclass.lisp 20 Feb 2011 11:13:06 -0000
@@ -231,18 +231,8 @@
((null head))
(unless (cdr (second head))
(setf (second head) (car (second head)))))
- (let* ((type-check-function
- (if (eq type t)
- nil
- `('type-check-function
- (named-lambda (slot-typecheck ,class-name ,name) (value)
- (declare (type ,type value)
- (optimize (sb-c:store-coverage-data 0)))
- value))))
- (canon `(:name ',name :readers ',readers :writers ',writers
- :initargs ',initargs
- ,@type-check-function
- ',others)))
+ (let ((canon `(:name ',name :readers ',readers :writers ',writers
+ :initargs ',initargs ',others)))
(push (if (eq initform unsupplied)
`(list* ,@canon)
`(list* :initfunction ,(make-initfunction initform)
@@ -471,6 +461,9 @@
(defun early-slot-definition-location (slotd)
(!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+(defun early-slot-definition-info (slotd)
+ (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'info))
+
(defun early-accessor-method-slot-name (method)
(!bootstrap-get-slot 'standard-accessor-method method 'slot-name))
Index: src/pcl/defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.72
diff -u -r1.72 defs.lisp
--- src/pcl/defs.lisp 30 Jul 2010 21:01:13 -0000 1.72
+++ src/pcl/defs.lisp 20 Feb 2011 11:13:07 -0000
@@ -453,9 +453,6 @@
:initarg :initargs
:accessor slot-definition-initargs)
(%type :initform t :initarg :type :accessor slot-definition-type)
- (%type-check-function :initform nil
- :initarg type-check-function
- :accessor slot-definition-type-check-function)
(%documentation
:initform nil :initarg :documentation
;; KLUDGE: we need a reader for bootstrapping purposes, in
@@ -501,14 +498,29 @@
())
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; (lambda (object) ...)
- :accessor slot-definition-reader-function)
- (writer-function ; (lambda (new-value object) ...)
- :accessor slot-definition-writer-function)
- (boundp-function ; (lambda (object) ...)
- :accessor slot-definition-boundp-function)
- (accessor-flags
- :initform 0)))
+ ((accessor-flags
+ :initform 0)
+ (info
+ :accessor slot-definition-info)))
+
+;;; We use a structure here, because fast slot-accesses to this information
+;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
+;;; these functions can access the SLOT-INFO directly, avoiding the overhead
+;;; of accessing a standard-instance.
+(defstruct (slot-info (:constructor make-slot-info
+ (&key slotd
+ typecheck
+ (type t)
+ (reader
+
(uninitialized-accessor-function :reader slotd))
+ (writer
+
(uninitialized-accessor-function :writer slotd))
+ (boundp
+
(uninitialized-accessor-function :boundp slotd)))))
+ (typecheck nil :type (or null function))
+ (reader (missing-arg) :type function)
+ (writer (missing-arg) :type function)
+ (boundp (missing-arg) :type function))
(defclass standard-direct-slot-definition (standard-slot-definition
direct-slot-definition)
Index: src/pcl/generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.43
diff -u -r1.43 generic-functions.lisp
--- src/pcl/generic-functions.lisp 26 Jun 2009 20:45:04 -0000 1.43
+++ src/pcl/generic-functions.lisp 20 Feb 2011 11:13:07 -0000
@@ -113,8 +113,6 @@
(defgeneric short-combination-operator (short-method-combination))
-(defgeneric slot-definition-boundp-function (effective-slot-definition))
-
(defgeneric slot-definition-class (slot-definition))
(defgeneric slot-definition-defstruct-accessor-symbol
@@ -136,14 +134,12 @@
(defgeneric slot-definition-name (slot-definition))
-(defgeneric slot-definition-reader-function (effective-slot-definition))
+(defgeneric slot-definition-info (effective-slot-definition))
(defgeneric slot-definition-readers (slot-definition))
(defgeneric slot-definition-type (slot-definition))
-(defgeneric slot-definition-writer-function (effective-slot-definition))
-
(defgeneric slot-definition-writers (slot-definition))
(defgeneric specializer-object (class-eq-specializer))
@@ -190,9 +186,6 @@
(defgeneric (setf slot-definition-allocation) (new-value
standard-slot-definition))
-(defgeneric (setf slot-definition-boundp-function)
- (new-value effective-slot-definition))
-
(defgeneric (setf slot-definition-class) (new-value slot-definition))
(defgeneric (setf slot-definition-defstruct-accessor-symbol)
@@ -215,8 +208,7 @@
(defgeneric (setf slot-definition-name) (new-value slot-definition))
-(defgeneric (setf slot-definition-reader-function) (new-value
- effective-slot-definition))
+(defgeneric (setf slot-definition-info) (new-value effective-slot-definition))
(defgeneric (setf slot-definition-readers) (new-value slot-definition))
Index: src/pcl/init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/init.lisp,v
retrieving revision 1.26
diff -u -r1.26 init.lisp
--- src/pcl/init.lisp 19 Jul 2010 07:05:39 -0000 1.26
+++ src/pcl/init.lisp 20 Feb 2011 11:13:07 -0000
@@ -60,6 +60,38 @@
(apply #'shared-initialize instance nil initargs)
instance)
+(defglobal **typecheck-cache** (make-hash-table :test #'equal))
+
+(defun generate-slotd-typecheck (slotd)
+ (let ((type (slot-definition-type slotd)))
+ (values
+ (when (and (neq t type) (safe-p (slot-definition-class slotd)))
+ (with-locked-hash-table (**typecheck-cache**)
+ (or (gethash type **typecheck-cache**)
+ (setf (gethash type **typecheck-cache**)
+ (handler-bind (((or style-warning compiler-note)
+ #'muffle-warning))
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare (optimize
(sb-c:store-coverage-data 0)
+ (sb-c::type-check 3)
+
(sb-c::verify-arg-count 0)))
+ (named-lambda (slot-typecheck ,type) (value)
+ (the ,type value))))))))))
+ type)))
+
+(defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
+ (setf (slot-definition-info slotd)
+ (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+ (make-slot-info :slotd slotd
+ :typecheck typecheck))))
+
+;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
+(defmethod (setf slot-definition-type) :after (new-type (slotd
effective-slot-definition))
+ (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+ (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
+
(defmethod update-instance-for-different-class
((previous standard-object) (current standard-object) &rest initargs)
;; First we must compute the newly added slots. The spec defines
Index: src/pcl/low.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/low.lisp,v
retrieving revision 1.54
diff -u -r1.54 low.lisp
--- src/pcl/low.lisp 13 Feb 2011 20:34:15 -0000 1.54
+++ src/pcl/low.lisp 20 Feb 2011 11:13:07 -0000
@@ -351,6 +351,12 @@
(member (dsd-name included-slot)
slot-overrides :test #'eq))
collect slot)))))
+(defun uninitialized-accessor-function (type slotd)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (error "~:(~A~) function~@[ for ~S ~] not yet initialized."
+ type slotd)))
+
(defun structure-slotd-name (slotd)
(dsd-name slotd))
@@ -358,13 +364,19 @@
(dsd-accessor-name slotd))
(defun structure-slotd-reader-function (slotd)
- (fdefinition (dsd-accessor-name slotd)))
+ (let ((name (dsd-accessor-name slotd)))
+ (if (fboundp name)
+ (fdefinition name)
+ (uninitialized-accessor-function :reader slotd))))
(defun structure-slotd-writer-function (type slotd)
(if (dsd-read-only slotd)
(let ((dd (find-defstruct-description type)))
(coerce (slot-setter-lambda-form dd slotd) 'function))
- (fdefinition `(setf ,(dsd-accessor-name slotd)))))
+ (let ((name `(setf ,(dsd-accessor-name slotd))))
+ (if (fboundp name)
+ (fdefinition name)
+ (uninitialized-accessor-function :writer slotd)))))
(defun structure-slotd-type (slotd)
(dsd-type slotd))
Index: src/pcl/methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.94
diff -u -r1.94 methods.lisp
--- src/pcl/methods.lisp 14 Oct 2010 16:32:52 -0000 1.94
+++ src/pcl/methods.lisp 20 Feb 2011 11:13:07 -0000
@@ -554,7 +554,6 @@
(warn "~@<Invalid qualifiers for ~S method combination ~
in method ~S:~2I~_~S.~@:>"
mc-name method qualifiers))))))
-
(unless skip-dfun-update-p
(update-ctors 'add-method
:generic-function generic-function
@@ -1542,15 +1541,15 @@
(defun slot-value-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-reader-function slotd) object))
+ (funcall (slot-info-reader (slot-definition-info slotd)) object))
(defun setf-slot-value-using-class-dfun (new-value class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-writer-function slotd) new-value object))
+ (funcall (slot-info-writer (slot-definition-info slotd)) new-value object))
(defun slot-boundp-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-boundp-function slotd) object))
+ (funcall (slot-info-boundp (slot-definition-info slotd)) object))
(defun special-case-for-compute-discriminating-function-p (gf)
(or (eq gf #'slot-value-using-class)
Index: src/pcl/slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.46
diff -u -r1.46 slots-boot.lisp
--- src/pcl/slots-boot.lisp 28 Feb 2010 18:51:56 -0000 1.46
+++ src/pcl/slots-boot.lisp 20 Feb 2011 11:13:07 -0000
@@ -141,10 +141,11 @@
(writer (slot-definition-internal-writer-function slotd))
(boundp (make-structure-slot-boundp-function slotd))))
((condition-class-p class)
- (ecase name
- (reader (slot-definition-reader-function slotd))
- (writer (slot-definition-writer-function slotd))
- (boundp (slot-definition-boundp-function slotd))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase name
+ (reader (slot-info-reader info))
+ (writer (slot-info-writer info))
+ (boundp (slot-info-boundp info)))))
(t
(let* ((fsc-p (cond ((standard-class-p class) nil)
((funcallable-standard-class-p class) t)
@@ -204,52 +205,71 @@
(instance-structure-protocol-error slotd 'slot-value-using-class))))
`(reader ,slot-name)))
-(defun make-optimized-std-writer-method-function
- (fsc-p slotd slot-name location)
+(defun make-optimized-std-writer-method-function (fsc-p slotd
slot-name location)
(declare #.*optimize-speed*)
- (let* ((safe-p (and slotd
- (slot-definition-class slotd)
- (safe-p (slot-definition-class slotd))))
+ ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
+ (let* ((class (when slotd (slot-definition-class slotd)))
+ (safe-p (when slotd (safe-p class)))
+ (orig-wrapper (when safe-p (class-wrapper class)))
+ (info (when safe-p (slot-definition-info slotd)))
(writer-fun (etypecase location
+ ;; In SAFE-P case the typechecking already
validated the instance.
(fixnum
(if fsc-p
+ (if safe-p
+ (lambda (nv instance)
+ (setf (clos-slots-ref
(fsc-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref
(fsc-instance-slots instance)
+ location)
+ nv)))
+ (if safe-p
+ (lambda (nv instance)
+ (setf (clos-slots-ref
(std-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref
(std-instance-slots instance)
+ location)
+ nv)))))
+ (cons
+ (if safe-p
(lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref
(fsc-instance-slots instance)
- location)
- nv))
+ (setf (cdr location) nv))
(lambda (nv instance)
(check-obsolete-instance instance)
- (setf (clos-slots-ref
(std-instance-slots instance)
- location)
- nv))))
- (cons
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (cdr location) nv)))
+ (setf (cdr location) nv))))
(null
(lambda (nv instance)
(declare (ignore nv instance))
(instance-structure-protocol-error
slotd
'(setf slot-value-using-class))))))
- (checking-fun (lambda (new-value instance)
- ;; If we have a TYPE-CHECK-FUNCTION, call it.
- (let* (;; Note that the class of INSTANCE here is not
- ;; neccessarily the SLOT-DEFINITION-CLASS of
- ;; the SLOTD passed to M-O-S-W-M-F, since it's
- ;; e.g. possible for a subclass to define a
- ;; slot of the same name but with no accessors.
- ;; So we need to fetch the right type
check function
- ;; from the wrapper instead of just
closing over it.
- (wrapper (valid-wrapper-of instance))
- (type-check-function
- (cadr (find-slot-cell wrapper slot-name))))
- (declare (type (or function null)
type-check-function))
- (when type-check-function
- (funcall type-check-function new-value)))
- ;; Then call the real writer.
- (funcall writer-fun new-value instance))))
+ (checking-fun (when safe-p
+ (lambda (new-value instance)
+ ;; If we have a TYPE-CHECK-FUNCTION, call it.
+ (let* (;; Note that the class of INSTANCE
here is not
+ ;; neccessarily the SLOT-DEFINITION-CLASS of
+ ;; the SLOTD passed to M-O-S-W-M-F,
since it's
+ ;; e.g. possible for a subclass to define a
+ ;; slot of the same name but with no
+ ;; accessors. So we may need to fetch the
+ ;; right SLOT-INFO from the wrapper
instead of
+ ;; just closing over it.
+ (wrapper (valid-wrapper-of instance))
+ (typecheck
+ (slot-info-typecheck
+ (if (eq wrapper orig-wrapper)
+ info
+ (cdr (find-slot-cell wrapper
slot-name))))))
+ (when typecheck
+ (funcall typecheck new-value)))
+ ;; Then call the real writer.
+ (funcall writer-fun new-value instance)))))
(set-fun-name (if safe-p
checking-fun
writer-fun)
@@ -309,25 +329,23 @@
(slot-definition-internal-writer-function slotd)))
(boundp
(make-optimized-structure-slot-boundp-using-class-method-function))))
((condition-class-p class)
- (ecase name
- (reader
- (let ((fun (slot-definition-reader-function slotd)))
- (declare (type function fun))
- (lambda (class object slotd)
- (declare (ignore class slotd))
- (funcall fun object))))
- (writer
- (let ((fun (slot-definition-writer-function slotd)))
- (declare (type function fun))
- (lambda (new-value class object slotd)
- (declare (ignore class slotd))
- (funcall fun new-value object))))
- (boundp
- (let ((fun (slot-definition-boundp-function slotd)))
- (declare (type function fun))
- (lambda (class object slotd)
- (declare (ignore class slotd))
- (funcall fun object))))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase name
+ (reader
+ (let ((fun (slot-info-reader info)))
+ (lambda (class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun object))))
+ (writer
+ (let ((fun (slot-info-writer info)))
+ (lambda (new-value class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun new-value object))))
+ (boundp
+ (let ((fun (slot-info-boundp info)))
+ (lambda (class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun object)))))))
(t
(let* ((fsc-p (cond ((standard-class-p class) nil)
((funcallable-standard-class-p class) t)
@@ -381,12 +399,11 @@
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slotd)
(declare #.*optimize-speed*)
- (let ((location (slot-definition-location slotd))
- (type-check-function
- (when (and slotd
- (slot-definition-class slotd)
- (safe-p (slot-definition-class slotd)))
- (slot-definition-type-check-function slotd))))
+ (let* ((location (slot-definition-location slotd))
+ (class (slot-definition-class slotd))
+ (typecheck
+ (when (safe-p class)
+ (slot-info-typecheck (slot-definition-info slotd)))))
(macrolet ((make-mf-lambda (&body body)
`(lambda (nv class instance slotd)
(declare (ignore class slotd))
@@ -396,9 +413,9 @@
;; Having separate lambdas for the NULL / not-NULL cases of
;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
;; for CLOS typechecking when it's not in use.
- `(if type-check-function
+ `(if typecheck
(make-mf-lambda
- (funcall (the function type-check-function) nv)
+ (funcall (the function typecheck) nv)
,@body)
(make-mf-lambda
,@body))))
@@ -459,69 +476,98 @@
(emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
+(defun maybe-class (class-or-name)
+ (when (eq **boot-state** 'complete)
+ (if (typep class-or-name 'class)
+ class-or-name
+ (find-class class-or-name nil))))
+
(defun make-std-reader-method-function (class-or-name slot-name)
(declare (ignore class-or-name))
- (let* ((initargs (copy-tree
- (make-method-function
- (lambda (instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-read-internal
- .pv. instance-slots 0
- (slot-value instance slot-name))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list (list nil slot-name)))
- initargs))
+ (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t)
+ (:standard
+ (let* ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-read-standard
+ .pv. instance-slots 0
+ (slot-value instance slot-name))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let* ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-read-custom .pv. 0 instance)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))))
(defun make-std-writer-method-function (class-or-name slot-name)
- (let* ((class (when (eq **boot-state** 'complete)
- (if (typep class-or-name 'class)
- class-or-name
- (find-class class-or-name nil))))
- (safe-p (and class
- (safe-p class)))
- (check-fun (lambda (new-value instance)
- (let* ((class (class-of instance))
- (slotd (find-slot-definition class slot-name))
- (type-check-function
- (when slotd
- (slot-definition-type-check-function slotd))))
- (when type-check-function
- (funcall type-check-function new-value)))))
- (initargs (copy-tree
- (if safe-p
- (make-method-function
- (lambda (nv instance)
- (funcall check-fun nv instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))
- (make-method-function
- (lambda (nv instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list nil (list nil slot-name)))
- initargs))
+ (let ((class (maybe-class class-or-name)))
+ (ecase (slot-access-strategy class slot-name 'writer t)
+ (:standard
+ (let ((initargs (copy-tree
+ (if (and class (safe-p class))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance
slot-name) .good-new-value.)
+ nil t))))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance
slot-name) .good-new-value.)))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-write-custom .pv. 0 instance nv)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs)))))
(defun make-std-boundp-method-function (class-or-name slot-name)
(declare (ignore class-or-name))
- (let* ((initargs (copy-tree
- (make-method-function
- (lambda (instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-boundp-internal
- .pv. instance-slots 0
- (slot-boundp instance slot-name))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list (list nil slot-name)))
- initargs))
+ (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t)
+ (:standard
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-boundp-standard
+ .pv. instance-slots 0
+ (slot-boundp instance slot-name))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-boundp-custom .pv. 0 instance)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))))
;;;; FINDING SLOT DEFINITIONS
;;;
@@ -565,10 +611,19 @@
;;; generic instead of checking versus STANDARD-CLASS and
;;; FUNCALLABLE-STANDARD-CLASS.
-(defun find-slot-definition (class slot-name)
- (dolist (slotd (class-slots class))
+(defun find-slot-definition (class slot-name &optional errorp)
+ (unless (class-finalized-p class)
+ (or (try-finalize-inheritance class)
+ (if errorp
+ (error "Cannot look up slot-definition for ~S in ~S (too
early to finalize.)"
+ slot-name class)
+ (return-from find-slot-definition (values nil nil)))))
+ (dolist (slotd (class-slots class)
+ (if errorp
+ (error "No slot called ~S in ~S." slot-name class)
+ (values nil t)))
(when (eq slot-name (slot-definition-name slotd))
- (return slotd))))
+ (return (values slotd t)))))
(defun find-slot-cell (wrapper slot-name)
(declare (symbol slot-name))
@@ -585,32 +640,27 @@
(defun make-slot-table (class slots &optional bootstrap)
(let* ((n (+ (length slots) 2))
- (vector (make-array n :initial-element nil))
- (save-slot-location-p
- (or bootstrap
- (when (eq 'complete **boot-state**)
- (let ((metaclass (class-of class)))
- (or (eq metaclass *the-class-standard-class*)
- (eq metaclass
*the-class-funcallable-standard-class*))))))
- (save-type-check-function-p
- (unless bootstrap
- (and (eq 'complete **boot-state**) (safe-p class)))))
+ (vector (make-array n :initial-element nil)))
(flet ((add-to-vector (name slot)
(declare (symbol name)
(optimize (sb-c::insert-array-bounds-checks 0)))
(let ((index (rem (sxhash name) n)))
(setf (svref vector index)
- (list* name (list* (when save-slot-location-p
- (if bootstrap
-
(early-slot-definition-location slot)
- (slot-definition-location slot)))
- (when save-type-check-function-p
-
(slot-definition-type-check-function slot))
- slot)
+ (list* name
+ (cons (when (or bootstrap
+ (and (standard-class-p class)
+ (slot-accessor-std-p
slot 'all)))
+ (if bootstrap
+ (early-slot-definition-location slot)
+ (slot-definition-location slot)))
+ (the slot-info
+ (if bootstrap
+ (early-slot-definition-info slot)
+ (slot-definition-info slot))))
(svref vector index))))))
(if (eq 'complete **boot-state**)
- (dolist (slot slots)
- (add-to-vector (slot-definition-name slot) slot))
- (dolist (slot slots)
- (add-to-vector (early-slot-definition-name slot) slot))))
+ (dolist (slot slots)
+ (add-to-vector (slot-definition-name slot) slot))
+ (dolist (slot slots)
+ (add-to-vector (early-slot-definition-name slot) slot))))
vector))
Index: src/pcl/slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.38
diff -u -r1.38 slots.lisp
--- src/pcl/slots.lisp 6 Aug 2009 15:57:26 -0000 1.38
+++ src/pcl/slots.lisp 20 Feb 2011 11:13:08 -0000
@@ -89,7 +89,10 @@
(declaim (ftype (sfunction (t symbol) t) slot-value))
(defun slot-value (object slot-name)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-value
+ (values (slot-missing (wrapper-class* wrapper)
object slot-name
+ 'slot-value)))))
(location (car cell))
(value
(cond ((fixnump location)
@@ -98,13 +101,9 @@
(funcallable-standard-instance-access object location)))
((consp location)
(cdr location))
- ((not cell)
- (return-from slot-value
- (values (slot-missing (wrapper-class* wrapper)
object slot-name
- 'slot-value))))
((not location)
(return-from slot-value
- (slot-value-using-class (wrapper-class* wrapper)
object (cddr cell))))
+ (funcall (slot-info-reader (cdr cell)) object)))
(t
(bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
(if (eq +slot-unbound+ value)
@@ -122,11 +121,15 @@
(defun set-slot-value (object slot-name new-value)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from set-slot-value
+ (values (slot-missing (wrapper-class* wrapper)
object slot-name
+ 'setf new-value)))))
(location (car cell))
- (type-check-function (cadr cell)))
- (when type-check-function
- (funcall (the function type-check-function) new-value))
+ (info (cdr cell))
+ (typecheck (slot-info-typecheck info)))
+ (when typecheck
+ (funcall typecheck new-value))
(cond ((fixnump location)
(if (std-instance-p object)
(setf (standard-instance-access object location) new-value)
@@ -134,11 +137,8 @@
new-value)))
((consp location)
(setf (cdr location) new-value))
- ((not cell)
- (slot-missing (wrapper-class* wrapper) object slot-name
'setf new-value))
((not location)
- (setf (slot-value-using-class (wrapper-class* wrapper)
object (cddr cell))
- new-value))
+ (funcall (slot-info-writer info) new-value object))
(t
(bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
new-value)
@@ -167,7 +167,11 @@
(defun slot-boundp (object slot-name)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-boundp
+ (and (slot-missing (wrapper-class* wrapper)
object slot-name
+ 'slot-boundp)
+ t))))
(location (car cell))
(value
(cond ((fixnump location)
@@ -176,14 +180,9 @@
(funcallable-standard-instance-access object location)))
((consp location)
(cdr location))
- ((not cell)
- (return-from slot-boundp
- (and (slot-missing (wrapper-class* wrapper) object slot-name
- 'slot-boundp)
- t)))
((not location)
(return-from slot-boundp
- (slot-boundp-using-class (wrapper-class* wrapper)
object (cddr cell))))
+ (funcall (slot-info-boundp (cdr cell)) object)))
(t
(bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
(not (eq +slot-unbound+ value))))
@@ -209,7 +208,8 @@
((not cell)
(slot-missing (wrapper-class* wrapper) object slot-name
'slot-makunbound))
((not location)
- (slot-makunbound-using-class (wrapper-class* wrapper)
object (cddr cell)))
+ (let ((class (wrapper-class* wrapper)))
+ (slot-makunbound-using-class class object
(find-slot-definition class slot-name))))
(t
(bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
object)
@@ -262,29 +262,27 @@
;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
;; instances. Are users allowed to call this directly?
(check-obsolete-instance object)
- (let ((location (slot-definition-location slotd))
- (type-check-function
- (when (safe-p class)
- (slot-definition-type-check-function slotd))))
- (flet ((check (new-value)
- (when type-check-function
- (funcall (the function type-check-function) new-value))
- new-value))
- (typecase location
- (fixnum
- (cond ((std-instance-p object)
- (setf (clos-slots-ref (std-instance-slots object) location)
- (check new-value)))
- ((fsc-instance-p object)
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- (check new-value)))
- (t (bug "unrecognized instance type in ~S"
- '(setf slot-value-using-class)))))
- (cons
- (setf (cdr location) (check new-value)))
- (t
- (instance-structure-protocol-error
- slotd '(setf slot-value-using-class)))))))
+ (let* ((info (slot-definition-info slotd))
+ (location (slot-definition-location slotd))
+ (typecheck (slot-info-typecheck info))
+ (new-value (if typecheck
+ (funcall (the function typecheck) new-value)
+ new-value)))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ new-value))
+ ((fsc-instance-p object)
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ new-value))
+ (t (bug "unrecognized instance type in ~S"
+ '(setf slot-value-using-class)))))
+ (cons
+ (setf (cdr location) new-value))
+ (t
+ (instance-structure-protocol-error
+ slotd '(setf slot-value-using-class))))))
(defmethod slot-boundp-using-class
((class std-class)
@@ -339,8 +337,7 @@
((class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-reader-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-reader (slot-definition-info slotd))))
(funcall fun object)))
(defmethod (setf slot-value-using-class)
@@ -348,16 +345,14 @@
(class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-writer-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-writer (slot-definition-info slotd))))
(funcall fun new-value object)))
(defmethod slot-boundp-using-class
((class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-boundp-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-boundp (slot-definition-info slotd))))
(funcall fun object)))
(defmethod slot-makunbound-using-class ((class condition-class) object slot)
@@ -430,7 +425,7 @@
instance
(etypecase position
(fixnum
- (nth position (wrapper-instance-slots-layout (wrapper-of instance))))
+ (car (nth position (wrapper-instance-slots-layout (wrapper-of
instance)))))
(cons
(car position))))))
Index: src/pcl/std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.133
diff -u -r1.133 std-class.lisp
--- src/pcl/std-class.lisp 2 Sep 2010 08:14:32 -0000 1.133
+++ src/pcl/std-class.lisp 20 Feb 2011 11:13:08 -0000
@@ -24,18 +24,20 @@
(in-package "SB-PCL")
(defmethod slot-accessor-function ((slotd effective-slot-definition) type)
- (ecase type
- (reader (slot-definition-reader-function slotd))
- (writer (slot-definition-writer-function slotd))
- (boundp (slot-definition-boundp-function slotd))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase type
+ (reader (slot-info-reader info))
+ (writer (slot-info-writer info))
+ (boundp (slot-info-boundp info)))))
(defmethod (setf slot-accessor-function) (function
(slotd effective-slot-definition)
type)
- (ecase type
- (reader (setf (slot-definition-reader-function slotd) function))
- (writer (setf (slot-definition-writer-function slotd) function))
- (boundp (setf (slot-definition-boundp-function slotd) function))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase type
+ (reader (setf (slot-info-reader info) function))
+ (writer (setf (slot-info-writer info) function))
+ (boundp (setf (slot-info-boundp info) function)))))
(defconstant +slotd-reader-function-std-p+ 1)
(defconstant +slotd-writer-function-std-p+ 2)
@@ -93,20 +95,20 @@
(null (cdr methods))))
(setf (slot-accessor-function slotd type)
(lambda (&rest args)
+ (declare (dynamic-extent args))
;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
;; work here (see KLUDGE comment above).
(let ((fun (compute-slot-accessor-info slotd type gf)))
(apply fun args))))))))
(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition))
- (let* ((name (slot-value slotd 'name)))
- (dolist (type '(reader writer boundp))
- (let* ((gf-name (ecase type
- (reader 'slot-value-using-class)
- (writer '(setf slot-value-using-class))
- (boundp 'slot-boundp-using-class)))
- (gf (gdefinition gf-name)))
- (compute-slot-accessor-info slotd type gf)))))
+ (dolist (type '(reader writer boundp))
+ (let* ((gf-name (ecase type
+ (reader 'slot-value-using-class)
+ (writer '(setf slot-value-using-class))
+ (boundp 'slot-boundp-using-class)))
+ (gf (gdefinition gf-name)))
+ (compute-slot-accessor-info slotd type gf))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
;;;
@@ -419,13 +421,15 @@
(t *the-class-standard-class*))
(nreverse reversed-plist)))))
+;;; This is used to call initfunctions of :allocation :class slots.
(defun call-initfun (fun slotd safe)
(declare (function fun))
(let ((value (funcall fun)))
(when safe
- (let ((typecheck (slot-definition-type-check-function slotd)))
- (when typecheck
- (funcall (the function typecheck) value))))
+ (let ((type (slot-definition-type slotd)))
+ (unless (or (eq t type)
+ (typep value type))
+ (error 'type-error :expected-type type :datum value))))
value))
(defmethod shared-initialize :after
@@ -535,7 +539,7 @@
(defmethod reinitialize-instance :before ((class slot-class) &key
direct-superclasses)
(dolist (old-super (set-difference (class-direct-superclasses
class) direct-superclasses))
(remove-direct-subclass old-super class))
- (remove-slot-accessors class (class-direct-slots class)))
+ (remove-slot-accessors class (class-direct-slots class)))
(defmethod reinitialize-instance :after ((class slot-class)
&rest initargs
@@ -610,18 +614,19 @@
(defmethod compute-effective-slot-definition
((class condition-class) slot-name dslotds)
- (let ((slotd (call-next-method)))
- (setf (slot-definition-reader-function slotd)
+ (let* ((slotd (call-next-method))
+ (info (slot-definition-info slotd)))
+ (setf (slot-info-reader info)
(lambda (x)
(handler-case (condition-reader-function x slot-name)
;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
;; is unbound; maybe it should be a CELL-ERROR of some
;; sort?
(error () (values (slot-unbound class x slot-name))))))
- (setf (slot-definition-writer-function slotd)
+ (setf (slot-info-writer info)
(lambda (v x)
(condition-writer-function x v slot-name)))
- (setf (slot-definition-boundp-function slotd)
+ (setf (slot-info-boundp info)
(lambda (x)
(multiple-value-bind (v c)
(ignore-errors (condition-reader-function x slot-name))
@@ -921,7 +926,9 @@
;; If there is a change in the shape of the instances then the
;; old class is now obsolete.
- (let* ((nlayout (mapcar #'slot-definition-name
+ (let* ((nlayout (mapcar (lambda (slotd)
+ (cons (slot-definition-name slotd)
+ (slot-definition-type slotd)))
(sort instance-slots #'<
:key #'slot-definition-location)))
(nslots (length nlayout))
@@ -1123,10 +1130,10 @@
eslotds))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
- (declare (ignore name))
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
- (class (apply #'effective-slot-definition-class class initargs)))
- (apply #'make-instance class initargs)))
+ (class (apply #'effective-slot-definition-class class initargs))
+ (slotd (apply #'make-instance class initargs)))
+ slotd))
(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
@@ -1145,7 +1152,6 @@
(allocation nil)
(allocation-class nil)
(type t)
- (type-check-function nil)
(documentation nil)
(documentationp nil)
(namep nil)
@@ -1171,16 +1177,6 @@
allocation-class (slot-definition-class slotd)
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
- (let ((fun (slot-definition-type-check-function slotd)))
- (when fun
- (setf type-check-function
- (if type-check-function
- (let ((old-function type-check-function))
- (declare (function old-function fun))
- (lambda (value)
- (funcall old-function value)
- (funcall fun value)))
- fun))))
(let ((slotd-type (slot-definition-type slotd)))
(setq type (cond
((eq type t) slotd-type)
@@ -1197,15 +1193,14 @@
:allocation allocation
:allocation-class allocation-class
:type type
- 'type-check-function type-check-function
:class class
:documentation documentation)))
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
- (let ((slotd (car direct-slotds)))
- (list* :defstruct-accessor-symbol
- (slot-definition-defstruct-accessor-symbol slotd)
+ (let* ((slotd (car direct-slotds))
+ (accessor (slot-definition-defstruct-accessor-symbol slotd)))
+ (list* :defstruct-accessor-symbol accessor
:internal-reader-function
(slot-definition-internal-reader-function slotd)
:internal-writer-function
@@ -1442,43 +1437,55 @@
(oclass-slots (wrapper-class-slots owrapper))
(added ())
(discarded ())
- (plist ()))
+ (plist ())
+ (safe (safe-p class)))
- ;; local --> local transfer value
+ ;; local --> local transfer value, check type
;; local --> shared discard value, discard slot
;; local --> -- discard slot
- ;; shared --> local transfer value
+ ;; shared --> local transfer value, check type
;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
;; shared --> -- discard value
;; -- --> local add slot
;; -- --> shared --
- ;; Go through all the old local slots.
- (let ((opos 0))
- (dolist (name olayout)
- (let ((npos (posq name nlayout)))
- (if npos
- (setf (clos-slots-ref nslots npos)
- (clos-slots-ref oslots opos))
- (progn
- (push name discarded)
- (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (clos-slots-ref oslots opos))))))
- (incf opos)))
-
- ;; Go through all the old shared slots.
- (dolist (oclass-slot-and-val oclass-slots)
- (let ((name (car oclass-slot-and-val))
- (val (cdr oclass-slot-and-val)))
- (let ((npos (posq name nlayout)))
- (when npos
- (setf (clos-slots-ref nslots npos) val)))))
+ (flet ((set-value (value npos &optional (otype t))
+ (when safe
+ (let ((ntype (cdr (nth npos nlayout))))
+ (unless (equal ntype otype)
+ (assert (typep value ntype) (value)
+ "~@<Error updating obsolete instance.
Current value in slot ~
+ ~S of an instance of ~S is ~S, which
does not match the new ~
+ slot type ~S.~:@>"
+ (car (nth npos nlayout)) class value ntype))))
+ (setf (clos-slots-ref nslots npos) value)))
+ ;; Go through all the old local slots.
+ (let ((opos 0))
+ (dolist (spec olayout)
+ (destructuring-bind (name . otype) spec
+ (let ((npos (position name nlayout :key #'car)))
+ (if npos
+ (set-value (clos-slots-ref oslots opos) npos otype)
+ (progn
+ (push name discarded)
+ (unless (eq (clos-slots-ref oslots opos)
+slot-unbound+)
+ (setf (getf plist name) (clos-slots-ref
oslots opos)))))))
+ (incf opos)))
+
+ ;; Go through all the old shared slots.
+ (dolist (oclass-slot-and-val oclass-slots)
+ (let ((name (car oclass-slot-and-val))
+ (val (cdr oclass-slot-and-val)))
+ (let ((npos (position name nlayout :key #'car)))
+ (when npos
+ (set-value val npos))))))
;; Go through all the new local slots to compute the added slots.
- (dolist (nlocal nlayout)
- (unless (or (memq nlocal olayout)
- (assq nlocal oclass-slots))
- (push nlocal added)))
+ (dolist (spec nlayout)
+ (let ((name (car spec)))
+ (unless (or (member name olayout :key #'car)
+ (assq name oclass-slots))
+ (push name added))))
(%swap-wrappers-and-slots instance copy)
@@ -1497,25 +1504,37 @@
(new-layout (wrapper-instance-slots-layout new-wrapper))
(old-slots (get-slots instance))
(new-slots (get-slots copy))
- (old-class-slots (wrapper-class-slots old-wrapper)))
+ (old-class-slots (wrapper-class-slots old-wrapper))
+ (safe (safe-p new-class)))
- ;; "The values of local slots specified by both the class CTO and
- ;; CFROM are retained. If such a local slot was unbound, it
- ;; remains unbound."
- (let ((new-position 0))
- (dolist (new-slot new-layout)
- (let ((old-position (posq new-slot old-layout)))
- (when old-position
- (setf (clos-slots-ref new-slots new-position)
- (clos-slots-ref old-slots old-position))))
- (incf new-position)))
-
- ;; "The values of slots specified as shared in the class CFROM and
- ;; as local in the class CTO are retained."
- (dolist (slot-and-val old-class-slots)
- (let ((position (posq (car slot-and-val) new-layout)))
- (when position
- (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
+ (flet ((set-value (value pos)
+ (when safe
+ (let ((spec (nth pos new-layout)))
+ (assert (typep value (cdr spec)) (value)
+ "~@<Error changing class. Current value in slot ~S ~
+ of an instance of ~S is ~S, which does not
match the new ~
+ slot type ~S in...
[truncated message content] |