From dfbfbd3f2499852904129738e13a70c9780f37a7 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 10 Sep 2007 20:55:11 +0000 Subject: [PATCH] 1.0.9.56: faster typechecking/optimized std-writer-method-functions * Fetch the type-check-fun from wrapper-slot-table, not from the slot-definition. --- src/pcl/slots-boot.lisp | 55 ++++++++++++++++++++++++------------------------- version.lisp-expr | 2 +- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 1baa57283..0514bf5dd 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -205,20 +205,22 @@ (slot-definition-class slotd) (safe-p (slot-definition-class slotd)))) (writer-fun (etypecase location - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - 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))) + (fixnum + (if fsc-p + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + 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))) (null (lambda (nv instance) (declare (ignore nv instance)) @@ -226,21 +228,18 @@ slotd '(setf slot-value-using-class)))))) (checking-fun (lambda (new-value instance) - (check-obsolete-instance instance) - ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it. - (let* (;; Note that this CLASS 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 SLOTD - ;; when CHECKING-FUN is called, instead of - ;; just closing over it. - (class (class-of instance)) - (slotd (find-slot-definition class slot-name)) + ;; 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 - (when slotd - (slot-definition-type-check-function slotd)))) + (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. diff --git a/version.lisp-expr b/version.lisp-expr index 6927c776c..fc99bc7ca 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,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.9.55" +"1.0.9.56" -- 2.11.4.GIT