hacking MNA "pcl cleanups" megapatch, phase I..
SB-PCL::%INSTANCE-REF and SB-PCL::INSTANCE-REF become
SB-PCL::CLOS-SLOTS-REF, an inline function.
DEF-CONSTANTLY-FUN doesn't want FDEFINITION after all.
* fixed bug 40: TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE,
and UPGRADED-COMPLEX-PART-TYPE now work better with of compound
types built from undefined types, e.g. '(VECTOR SOME-UNDEF-TYPE).
-* The Gray subclassable streams extension now works, thanks to a
- patch from Martin Atzmueller.
* DESCRIBE now works on structure objects again.
+* Most function call argument type mismatches are now handled as
+ STYLE-WARNINGs instead of full WARNINGs, since the compiler doesn't
+ know whether the function will be redefined before the call is
+ executed. (The compiler could flag local calls with full WARNINGs,
+ as per the ANSI spec "3.2.2.3 Semantic Constraints", but right now
+ it doesn't keep track of enough information to know whether calls
+ are local in this sense.)
* Compiler output is now more verbose, with messages truncated
later than before. (There should be some supported way for users
to override the default verbosity, but I haven't decided how to
provide it yet, so this behavior is still controlled by the internal
SB-C::*COMPILER-ERROR-PRINT-FOO* variables in
src/compiler/ir1util.lisp.)
+* Fasl file format version numbers have increased again, because
+ support for the Gray streams extension changes the layout of the
+ system's STREAM objects.
+* The Gray subclassable streams extension now works, thanks to a
+ patch from Martin Atzmueller.
* The full LOAD-FOREIGN extension (not just the primitive
LOAD-FOREIGN-1) now works, thanks to a patch from Martin Atzmueller.
* The default behavior of RUN-PROGRAM has changed. Now, unlike CMU CL
for porting convenience.
* LOAD-FOREIGN (and LOAD-1-FOREIGN) now support logical pathnames,
as per Daniel Barlow's suggestion and Martin Atzmueller's patch
-* Fasl file format version numbers have increased again, because
- support for the Gray streams extension changes the layout of the
- system's STREAM objects.
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
* When the profiling interface settles down, it might impact TRACE.
They both encapsulate functions, and it's not clear yet how
e.g. UNPROFILE will interact with TRACE and UNTRACE. (This shouldn't
- matter, though, unless you are using profiling.)
+ matter, though, unless you are using profiling. If you never
+ profile anything, TRACE should continue to behave as before.)
`(((typep ,emf 'fixnum)
(let* ((.slots. (get-slots-or-nil
,(car required-args+rest-arg)))
- (value (when .slots. (instance-ref .slots. ,emf))))
+ (value (when .slots. (clos-slots-ref .slots. ,emf))))
(if (eq value +slot-unbound+)
(slot-unbound-internal ,(car required-args+rest-arg)
,emf)
(.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
(when .slots.
- (setf (instance-ref .slots. ,emf) .new-value.))))))
+ (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
#||
,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
`(((typep ,emf 'fast-instance-boundp)
(let ((.slots. (get-slots-or-nil
,(car required-args+rest-arg))))
(and .slots.
- (not (eq (instance-ref
+ (not (eq (clos-slots-ref
.slots. (fast-instance-boundp-index ,emf))
+slot-unbound+)))))))
||#
(cond ((null args) (error "1 or 2 args were expected."))
((null (cdr args))
(let* ((slots (get-slots (car args)))
- (value (instance-ref slots emf)))
+ (value (clos-slots-ref slots emf)))
(if (eq value +slot-unbound+)
(slot-unbound-internal (car args) emf)
value)))
((null (cddr args))
- (setf (instance-ref (get-slots (cadr args)) emf)
- (car args)))
+ (setf (clos-slots-ref (get-slots (cadr args)) emf)
+ (car args)))
(t (error "1 or 2 args were expected."))))
(fast-instance-boundp
(if (or (null args) (cdr args))
(error "1 arg was expected.")
(let ((slots (get-slots (car args))))
- (not (eq (instance-ref slots
- (fast-instance-boundp-index emf))
+ (not (eq (clos-slots-ref slots
+ (fast-instance-boundp-index emf))
+slot-unbound+)))))
(function
(apply emf args))))
(defun early-gf-p (x)
(and (fsc-instance-p x)
- (eq (instance-ref (get-slots x) *sgf-method-class-index*)
+ (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*)
+slot-unbound+)))
(defvar *sgf-methods-index*
(!bootstrap-slot-index 'standard-generic-function 'methods))
(defmacro early-gf-methods (gf)
- `(instance-ref (get-slots ,gf) *sgf-methods-index*))
+ `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
(defvar *sgf-arg-info-index*
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
(defmacro early-gf-arg-info (gf)
- `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
+ `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*))
(defvar *sgf-dfun-state-index*
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
dfun)))
(if (eq *boot-state* 'complete)
(setf (gf-dfun-state gf) new-state)
- (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
+ (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
+ new-state)))
dfun)
(defun gf-dfun-cache (gf)
(let ((state (if (eq *boot-state* 'complete)
(gf-dfun-state gf)
- (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(cons (cadr state)))))
(defun gf-dfun-info (gf)
(let ((state (if (eq *boot-state* 'complete)
(gf-dfun-state gf)
- (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(cons (cddr state)))))
(!bootstrap-slot-index 'standard-generic-function 'name))
(defun !early-gf-name (gf)
- (instance-ref (get-slots gf) *sgf-name-index*))
+ (clos-slots-ref (get-slots gf) *sgf-name-index*))
(defun gf-lambda-list (gf)
(let ((arg-info (if (eq *boot-state* 'complete)
(push val .initargs.)
(push initarg .initargs.))
(dolist (pos (cddr entry))
- (setf (instance-ref .slots. pos) val))))
+ (setf (clos-slots-ref .slots. pos) val))))
,@(gathering1 (collecting)
(doplist (initarg value) supplied-initargs
(push .value. .initargs.)
(push ',initarg .initargs.)
(dolist (.p. (pop .positions.))
- (setf (instance-ref .slots. .p.)
+ (setf (clos-slots-ref .slots. .p.)
.value.)))))))
(dolist (fn .shared-initfns.)
(dolist (entry .initfns-and-positions.)
(let ((val (funcall (car entry))))
(dolist (pos (cdr entry))
- (setf (instance-ref .slots. pos) val))))
+ (setf (clos-slots-ref .slots. pos) val))))
,@(gathering1 (collecting)
(doplist (initarg value) supplied-initargs
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (instance-ref .slots. .p.) .value.)))))))
+ (setf (clos-slots-ref .slots. .p.)
+ .value.)))))))
.instance.))))))))
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (instance-ref .slots. .p.)
- .value.)))))))
+ (setf (clos-slots-ref .slots. .p.)
+ .value.)))))))
.instance.))))))))))
(defstruct-p (and (eq *boot-state* 'complete)
(let ((mclass (find-class metaclass nil)))
(and mclass
- (*subtypep mclass
- *the-class-structure-class*))))))
+ (*subtypep
+ mclass
+ *the-class-structure-class*))))))
(let ((defclass-form
(eval-when (:load-toplevel :execute)
`(progn
(loop (when (null others) (return nil))
(let ((initarg (pop others)))
(unless (eq initarg :direct-default-initargs)
- (error "The defclass option ~S is not supported by the bootstrap~%~
- object system."
+ (error "~@<The defclass option ~S is not supported by ~
+ the bootstrap object system.~:@>"
initarg)))
(setq default-initargs
(nconc default-initargs (reverse (pop others)))))))
;;; standard slots must be computed the same way in this file as it is
;;; by the full object system later.
(defmacro !bootstrap-get-slot (type object slot-name)
- `(instance-ref (get-slots ,object) (!bootstrap-slot-index ,type ,slot-name)))
+ `(clos-slots-ref (get-slots ,object)
+ (!bootstrap-slot-index ,type ,slot-name)))
(defun !bootstrap-set-slot (type object slot-name new-value)
(setf (!bootstrap-get-slot type object slot-name) new-value))
(defun emit-slot-read-form (class-slot-p index slots)
(if class-slot-p
`(cdr ,index)
- `(instance-ref ,slots ,index)))
+ `(clos-slots-ref ,slots ,index)))
(defun emit-slot-write-form (class-slot-p index slots value)
(if class-slot-p
`(setf (cdr ,index) ,value)
- `(and ,slots (setf (instance-ref ,slots ,index) ,value))))
+ `(and ,slots (setf (clos-slots-ref ,slots ,index) ,value))))
(defun emit-boundp-check (value-form miss-fn arglist)
`(let ((value ,value-form))
(if *inline-iis-instance-locations-p*
(typecase location
(fixnum `((and slots
- (setf (instance-ref slots ,(const location))
- value))))
+ (setf (clos-slots-ref slots ,(const location))
+ value))))
(cons `((setf (cdr ,(const location)) value)))
(t `(,default)))
`((instance-write-internal pv slots ,(const pv-offset) value
`((unless ,(if *inline-iis-instance-locations-p*
(typecase location
(fixnum `(not (and slots
- (eq (instance-ref slots ,(const location))
+ (eq (clos-slots-ref
+ slots
+ ,(const location))
+slot-unbound+))))
- (cons `(not (eq (cdr ,(const location)) +slot-unbound+)))
+ (cons `(not (eq (cdr ,(const location))
+ +slot-unbound+)))
(t default))
- `(instance-boundp-internal pv slots ,(const pv-offset)
+ `(instance-boundp-internal
+ pv slots ,(const pv-offset)
,default
,(typecase (pvref pv pv-offset)
(fixnum ':instance)
(t ':default))))
,@(let ((sforms (cons nil nil)))
(dotimes-fixnum (i (cadddr form) (car sforms))
- (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
+ (add-forms (first-form-to-lisp forms cvector pv)
+ sforms)))))))
(update-initialize-info-cache
`((when (consp initargs)
(setq initargs (cons (car initargs) (cdr initargs))))
(declare (fixnum ,var))
,@body))
\f
-
-(defmacro instance-ref (slots index)
- `(svref ,slots ,index))
+(declaim (ftype (function (simple-vector index) t) clos-slots-ref))
+(defun clos-slots-ref (slots index)
+ (svref slots index))
+(declaim (ftype (function (t simple-vector index) t) (setf clos-slots-ref)))
+(defun (setf clos-slots-ref) (new-value slots index)
+ (setf (svref slots index) new-value))
;;; Note on implementation under CMU CL >=17 and SBCL: STD-INSTANCE-P
;;; is only used to discriminate between functions (including FINs)
;;; and normal instances, so we can return true on structures also. A
-;;; few uses of (or std-instance-p fsc-instance-p) are changed to
-;;; pcl-instance-p.
+;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to
+;;; PCL-INSTANCE-P.
(defmacro std-instance-p (x)
`(sb-kernel:%instancep ,x))
(defun pcl-instance-p (x)
(typep (sb-kernel:layout-of x) 'wrapper))
-;;; We define this as STANDARD-INSTANCE, since we're going to clobber the
-;;; layout with some standard-instance layout as soon as we make it, and we
-;;; want the accessor to still be type-correct.
+;;; We define this as STANDARD-INSTANCE, since we're going to clobber
+;;; the layout with some standard-instance layout as soon as we make
+;;; it, and we want the accessor to still be type-correct.
(defstruct (standard-instance
(:predicate nil)
(:constructor %%allocate-instance--class ())
;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
(macrolet ((def-constantly-fun (name constant-expr)
- `(name-set-fdefinition ',name
+ `(setf (symbol-function ',name)
(constantly ,constant-expr))))
(def-constantly-fun constantly-t t)
(def-constantly-fun constantly-nil nil)
(set-function-name
(etypecase index
(fixnum (if fsc-p
- #'(lambda (instance)
- (let ((value (instance-ref (fsc-instance-slots instance) index)))
- (if (eq value +slot-unbound+)
- (slot-unbound (class-of instance) instance slot-name)
- value)))
- #'(lambda (instance)
- (let ((value (instance-ref (std-instance-slots instance) index)))
- (if (eq value +slot-unbound+)
- (slot-unbound (class-of instance) instance slot-name)
- value)))))
- (cons #'(lambda (instance)
- (let ((value (cdr index)))
- (if (eq value +slot-unbound+)
- (slot-unbound (class-of instance) instance slot-name)
- value)))))
+ (lambda (instance)
+ (let ((value (clos-slots-ref (fsc-instance-slots instance)
+ index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))
+ (lambda (instance)
+ (let ((value (clos-slots-ref (std-instance-slots instance)
+ index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))))
+ (cons (lambda (instance)
+ (let ((value (cdr index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))))
`(reader ,slot-name)))
(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
(set-function-name
(etypecase index
(fixnum (if fsc-p
- #'(lambda (nv instance)
- (setf (instance-ref (fsc-instance-slots instance) index) nv))
- #'(lambda (nv instance)
- (setf (instance-ref (std-instance-slots instance) index) nv))))
- (cons #'(lambda (nv instance)
- (declare (ignore instance))
- (setf (cdr index) nv))))
+ (lambda (nv instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance) index)
+ nv))
+ (lambda (nv instance)
+ (setf (clos-slots-ref (std-instance-slots instance) index)
+ nv))))
+ (cons (lambda (nv instance)
+ (declare (ignore instance))
+ (setf (cdr index) nv))))
`(writer ,slot-name)))
(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
(etypecase index
(fixnum (if fsc-p
#'(lambda (instance)
- (not (eq (instance-ref (fsc-instance-slots instance)
+ (not (eq (clos-slots-ref (fsc-instance-slots instance)
index)
+slot-unbound+)))
#'(lambda (instance)
- (not (eq (instance-ref (std-instance-slots instance)
+ (not (eq (clos-slots-ref (std-instance-slots instance)
index)
+slot-unbound+)))))
(cons #'(lambda (instance)
(defun make-optimized-structure-slot-value-using-class-method-function (function)
(declare (type function function))
- #'(lambda (class object slotd)
- (let ((value (funcall function object)))
- (if (eq value +slot-unbound+)
- (slot-unbound class object (slot-definition-name slotd))
- value))))
+ (lambda (class object slotd)
+ (let ((value (funcall function object)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class object (slot-definition-name slotd))
+ value))))
(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
(declare (type function function))
(declare (ignore class slotd))
(not (eq (funcall function object) +slot-unbound+))))
-(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
+(defun get-optimized-std-slot-value-using-class-method-function (class
+ slotd
+ name)
(if (structure-class-p class)
(ecase name
(reader (make-optimized-structure-slot-value-using-class-method-function
(declare #.*optimize-speed*)
(etypecase index
(fixnum (if fsc-p
- #'(lambda (class instance slotd)
- (declare (ignore slotd))
- (unless (fsc-instance-p instance) (error "not fsc"))
- (let ((value (instance-ref (fsc-instance-slots instance) index)))
- (if (eq value +slot-unbound+)
- (slot-unbound class instance slot-name)
- value)))
- #'(lambda (class instance slotd)
- (declare (ignore slotd))
- (unless (std-instance-p instance) (error "not std"))
- (let ((value (instance-ref (std-instance-slots instance) index)))
- (if (eq value +slot-unbound+)
- (slot-unbound class instance slot-name)
- value)))))
- (cons #'(lambda (class instance slotd)
- (declare (ignore slotd))
- (let ((value (cdr index)))
- (if (eq value +slot-unbound+)
- (slot-unbound class instance slot-name)
- value))))))
+ (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (unless (fsc-instance-p instance) (error "not fsc"))
+ (let ((value (clos-slots-ref (fsc-instance-slots instance)
+ index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class instance slot-name)
+ value)))
+ (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (unless (std-instance-p instance) (error "not std"))
+ (let ((value (clos-slots-ref (std-instance-slots instance)
+ index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class instance slot-name)
+ value)))))
+ (cons (lambda (class instance slotd)
+ (declare (ignore slotd))
+ (let ((value (cdr index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class instance slot-name)
+ value))))))
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slot-name index)
(declare (ignore slot-name))
(etypecase index
(fixnum (if fsc-p
- #'(lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (setf (instance-ref (fsc-instance-slots instance) index) nv))
- #'(lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (setf (instance-ref (std-instance-slots instance) index) nv))))
- (cons #'(lambda (nv class instance slotd)
- (declare (ignore class instance slotd))
- (setf (cdr index) nv)))))
+ (lambda (nv class instance slotd)
+ (declare (ignore class slotd))
+ (setf (clos-slots-ref (fsc-instance-slots instance) index)
+ nv))
+ (lambda (nv class instance slotd)
+ (declare (ignore class slotd))
+ (setf (clos-slots-ref (std-instance-slots instance) index)
+ nv))))
+ (cons (lambda (nv class instance slotd)
+ (declare (ignore class instance slotd))
+ (setf (cdr index) nv)))))
(defun make-optimized-std-slot-boundp-using-class-method-function
(fsc-p slot-name index)
(declare (ignore slot-name))
(etypecase index
(fixnum (if fsc-p
- #'(lambda (class instance slotd)
- (declare (ignore class slotd))
- (not (eq (instance-ref (fsc-instance-slots instance)
- index)
- +slot-unbound+ )))
- #'(lambda (class instance slotd)
- (declare (ignore class slotd))
- (not (eq (instance-ref (std-instance-slots instance)
- index)
- +slot-unbound+ )))))
- (cons #'(lambda (class instance slotd)
- (declare (ignore class instance slotd))
- (not (eq (cdr index) +slot-unbound+))))))
+ (lambda (class instance slotd)
+ (declare (ignore class slotd))
+ (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
+ +slot-unbound+)))
+ (lambda (class instance slotd)
+ (declare (ignore class slotd))
+ (not (eq (clos-slots-ref (std-instance-slots instance) index)
+ +slot-unbound+)))))
+ (cons (lambda (class instance slotd)
+ (declare (ignore class instance slotd))
+ (not (eq (cdr index) +slot-unbound+))))))
(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
(macrolet ((emf-funcall (emf &rest args)
`(invoke-effective-method-function ,emf nil ,@args)))
(set-function-name
(case name
- (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
- (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
- (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
+ (reader (lambda (instance)
+ (emf-funcall sdfun class instance slotd)))
+ (writer (lambda (nv instance)
+ (emf-funcall sdfun nv class instance slotd)))
+ (boundp (lambda (instance)
+ (emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
(defun make-internal-reader-method-function (class-name slot-name)
(if wrapper
(let* ((class (wrapper-class* wrapper))
(index (or (instance-slot-index wrapper slot-name)
- (assq slot-name (wrapper-class-slots wrapper)))))
+ (assq slot-name
+ (wrapper-class-slots wrapper)))))
(typecase index
(fixnum
- (let ((value (instance-ref (get-slots instance) index)))
+ (let ((value (clos-slots-ref (get-slots instance)
+ index)))
(if (eq value +slot-unbound+)
- (slot-unbound (class-of instance) instance slot-name)
+ (slot-unbound (class-of instance)
+ instance
+ slot-name)
value)))
(cons
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
- (slot-unbound (class-of instance) instance slot-name)
+ (slot-unbound (class-of instance)
+ instance
+ slot-name)
value)))
(t
- (error "The wrapper for class ~S does not have the slot ~S"
+ (error "~@<The wrapper for class ~S does not have ~
+ the slot ~S~@:>"
class slot-name))))
(slot-value instance slot-name)))))))
\f
default))
\f
(defun standard-instance-access (instance location)
- (instance-ref (std-instance-slots instance) location))
+ (clos-slots-ref (std-instance-slots instance) location))
(defun funcallable-standard-instance-access (instance location)
- (instance-ref (fsc-instance-slots instance) location))
+ (clos-slots-ref (fsc-instance-slots instance) location))
(defmethod slot-value-using-class ((class std-class)
(object std-object)
(unless (eq t (wrapper-state (std-instance-wrapper
object)))
(check-wrapper-validity object))
- (instance-ref (std-instance-slots object) location))
+ (clos-slots-ref (std-instance-slots object)
+ location))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper
object)))
(check-wrapper-validity object))
- (instance-ref (fsc-instance-slots object) location))
+ (clos-slots-ref (fsc-instance-slots object)
+ location))
(t (error "unrecognized instance type"))))
(cons
(cdr location))
(cond ((std-instance-p object)
(unless (eq t (wrapper-state (std-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (instance-ref (std-instance-slots object) location)
- new-value))
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ new-value))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (instance-ref (fsc-instance-slots object) location)
- new-value))
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ new-value))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) new-value))
(unless (eq t (wrapper-state (std-instance-wrapper
object)))
(check-wrapper-validity object))
- (instance-ref (std-instance-slots object) location))
+ (clos-slots-ref (std-instance-slots object)
+ location))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper
object)))
(check-wrapper-validity object))
- (instance-ref (fsc-instance-slots object) location))
+ (clos-slots-ref (fsc-instance-slots object)
+ location))
(t (error "unrecognized instance type"))))
(cons
(cdr location))
(cond ((std-instance-p object)
(unless (eq t (wrapper-state (std-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (instance-ref (std-instance-slots object) location)
- +slot-unbound+))
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ +slot-unbound+))
((fsc-instance-p object)
(unless (eq t (wrapper-state (fsc-instance-wrapper object)))
(check-wrapper-validity object))
- (setf (instance-ref (fsc-instance-slots object) location)
- +slot-unbound+))
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ +slot-unbound+))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) +slot-unbound+))
(opos (interval :from 0)))
(let ((npos (posq name nlayout)))
(if npos
- (setf (instance-ref nslots npos) (instance-ref oslots opos))
+ (setf (clos-slots-ref nslots npos)
+ (clos-slots-ref oslots opos))
(progn
(push name discarded)
- (unless (eq (instance-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (instance-ref oslots opos)))))))
+ (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
+ (setf (getf plist name) (clos-slots-ref oslots opos)))))))
;; Go through all the old shared slots.
(iterate ((oclass-slot-and-val (list-elements oclass-slots)))
(val (cdr oclass-slot-and-val)))
(let ((npos (posq name nlayout)))
(if npos
- (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
+ (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
(progn (push name discarded)
(unless (eq val +slot-unbound+)
(setf (getf plist name) val)))))))
(new-position (interval :from 0)))
(let ((old-position (posq new-slot old-layout)))
(when old-position
- (setf (instance-ref new-slots new-position)
- (instance-ref old-slots old-position)))))
+ (setf (clos-slots-ref new-slots new-position)
+ (clos-slots-ref old-slots old-position)))))
;; "The values of slots specified as shared in the class CFROM and
;; as local in the class CTO are retained."
(iterate ((slot-and-val (list-elements old-class-slots)))
(let ((position (posq (car slot-and-val) new-layout)))
(when position
- (setf (instance-ref new-slots position) (cdr slot-and-val)))))
+ (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
;; Make the copy point to the old instance's storage, and make the
;; old instance point to the new storage.
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (instance-ref ,slots ,index))))
+ `((fixnum (clos-slots-ref ,slots ,index))))
,@(when (or (null type) (eq type ':class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (setf (instance-ref ,slots ,index)
- ,new-value))))
+ `((fixnum (setf (clos-slots-ref ,slots ,index)
+ ,new-value))))
,@(when (or (null type) (eq type ':class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
`((fixnum (not (and ,slots
- (eq (instance-ref ,slots ,index)
+ (eq (clos-slots-ref ,slots ,index)
+slot-unbound+))))))
,@(when (or (null type) (eq type ':class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.10.19"
+"0.6.10.20"
projects / sbcl.git / commitdiff