From: William Harold Newman Date: Thu, 22 Feb 2001 17:27:20 +0000 (+0000) Subject: 0.6.10.20: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=26b8ddda97fcfa2e2c0eae3bd2fdb19717c5fa40;p=sbcl.git 0.6.10.20: 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. --- diff --git a/NEWS b/NEWS index 92c8ae4..3b5fbdf 100644 --- a/NEWS +++ b/NEWS @@ -649,15 +649,25 @@ changes in sbcl-0.6.11 relative to sbcl-0.6.10: * 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 @@ -670,9 +680,6 @@ changes in sbcl-0.6.11 relative to sbcl-0.6.10: 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. @@ -683,4 +690,5 @@ planned incompatible changes in 0.7.x: * 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.) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c698023..81145aa 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -817,7 +817,7 @@ bootstrapping. `(((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) @@ -828,14 +828,14 @@ bootstrapping. (.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+))))))) ||# @@ -888,20 +888,20 @@ bootstrapping. (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)))) @@ -1406,20 +1406,20 @@ bootstrapping. (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)) @@ -1681,13 +1681,14 @@ bootstrapping. 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))))) @@ -1695,7 +1696,7 @@ bootstrapping. (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))))) @@ -1704,7 +1705,7 @@ bootstrapping. (!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) diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index bb1a24c..b7f9ac2 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -637,7 +637,7 @@ (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 @@ -646,7 +646,7 @@ (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.) @@ -784,7 +784,7 @@ (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 @@ -792,7 +792,8 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (instance-ref .slots. .p.) .value.))))))) + (setf (clos-slots-ref .slots. .p.) + .value.))))))) .instance.)))))))) @@ -914,8 +915,8 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (instance-ref .slots. .p.) - .value.))))))) + (setf (clos-slots-ref .slots. .p.) + .value.))))))) .instance.)))))))))) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 022f979..4a66e98 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -88,8 +88,9 @@ (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 @@ -281,8 +282,8 @@ (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 "~@" initarg))) (setq default-initargs (nconc default-initargs (reverse (pop others))))))) @@ -308,7 +309,8 @@ ;;; 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)) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 0f4d06b..b42997a 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -163,12 +163,12 @@ (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)) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 85400fe..ced77f4 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -827,8 +827,8 @@ (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 @@ -845,11 +845,15 @@ `((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) @@ -857,7 +861,8 @@ (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)))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 1de5266..b6c25a1 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -46,15 +46,18 @@ (declare (fixnum ,var)) ,@body)) - -(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)) @@ -184,9 +187,9 @@ (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 ()) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 4025d9b..dcb5df5 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -51,7 +51,7 @@ ;;; 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) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 4129a81..998b02b 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -140,21 +140,23 @@ (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) @@ -162,13 +164,15 @@ (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) @@ -177,11 +181,11 @@ (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) @@ -191,11 +195,11 @@ (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)) @@ -209,7 +213,9 @@ (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 @@ -239,26 +245,28 @@ (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) @@ -266,15 +274,17 @@ (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) @@ -282,28 +292,29 @@ (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) @@ -314,20 +325,27 @@ (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 "~@" class slot-name)))) (slot-value instance slot-name))))))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 27bc917..6d82bcd 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -181,10 +181,10 @@ default)) (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) @@ -198,12 +198,14 @@ (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)) @@ -226,13 +228,13 @@ (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)) @@ -252,12 +254,14 @@ (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)) @@ -278,13 +282,13 @@ (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+)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ecbc785..2327178 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1099,11 +1099,12 @@ (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))) @@ -1111,7 +1112,7 @@ (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))))))) @@ -1159,15 +1160,15 @@ (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. diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 212a182..524a854 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -663,7 +663,7 @@ (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+))) @@ -697,8 +697,8 @@ (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))))))) @@ -745,7 +745,7 @@ (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+))))) diff --git a/version.lisp-expr b/version.lisp-expr index c4d0b34..e176e54 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; 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"