From 44a9552782f2d059e2f211118aef7512972e376d Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Wed, 10 Oct 2012 21:56:43 +0200 Subject: [PATCH] Remove the phases that create accessors in fixup.lsp and in slot.lsp --- src/clos/fixup.lsp | 9 --- src/clos/kernel.lsp | 11 ++-- src/clos/slot.lsp | 16 ----- src/clos/std-accessors.lsp | 119 +++++++++++++++++++------------------ 4 files changed, 66 insertions(+), 89 deletions(-) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index cb01223ff..5cd3e2859 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -200,15 +200,6 @@ their lambda lists ~A and ~A are not congruent." (function-to-method 'find-method '((gf standard-generic-function) qualifiers specializers &optional error)) -(labels ((create-accessors (class) - (when (and (typep class 'standard-class) - (not (member (find-class 'slot-definition) - (class-precedence-list class)))) - (std-class-generate-accessors class)) - (loop for i in (class-direct-subclasses class) - do (create-accessors i)))) - (create-accessors (find-class 't))) - ;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places, ;;; including instance initialization. This means we cannot just redefine it. ;;; Instead, we create an auxiliary function and move definitions from one to diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index d5a22506c..ec72b924f 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -168,28 +168,29 @@ ;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with ;; a similar implementation in C (compute-discriminating-function gfun) - (let ((methods (generic-function-methods gfun))) + (let ((methods (slot-value gfun 'methods))) (set-funcallable-instance-function gfun (cond ;; Case 1* ((or (not optimizable) - (> (length (generic-function-spec-list gfun)) + (> (length (slot-value gfun 'spec-list)) si::c-arguments-limit)) default-function) ;; Case 2* - ((and (not (eq (class-id (class-of gfun)) 'standard-generic-function)) + ((and (not (eq (slot-value (class-of gfun) 'name) + 'standard-generic-function)) *clos-booted*) t) ((null methods) 'standard-generic-function) ;; Cases 3* ((loop with class = (find-class 'standard-reader-method nil) - for m in (generic-function-methods gfun) + for m in methods always (eq class (class-of m))) 'standard-reader-method) ((loop with class = (find-class 'standard-writer-method nil) - for m in (generic-function-methods gfun) + for m in methods always (eq class (class-of m))) 'standard-writer-method) ;; Case 4* diff --git a/src/clos/slot.lsp b/src/clos/slot.lsp index 90e3176ad..16fa40c97 100644 --- a/src/clos/slot.lsp +++ b/src/clos/slot.lsp @@ -62,22 +62,6 @@ collect (getf rest :initarg) collect `(,(getf rest :accessor) slotd)))) -(loop with all-slots = '#.+slot-definition-slots+ - for slotd in all-slots - for i from 0 - for fname = (getf (rest slotd) :accessor) - do (let ((name (first slotd))) - (setf (fdefinition fname) - #'(lambda (x) - (if (consp x) - (nth position x) - (slot-value x name))) - (fdefinition `(setf ,fname)) - #'(lambda (v x) - (if (consp x) - (setf (nth position x) v) - (setf (slot-value x name) v)))))) - ;;; ---------------------------------------------------------------------- ;;; ;;; (PARSE-SLOTS slot-definition-form) => slot-definition-object diff --git a/src/clos/std-accessors.lsp b/src/clos/std-accessors.lsp index 3771bc345..08d0e7b91 100644 --- a/src/clos/std-accessors.lsp +++ b/src/clos/std-accessors.lsp @@ -21,9 +21,10 @@ ;;; (defun safe-slot-definition-location (slotd &optional default) - (if (or (listp slotd) (slot-boundp slotd 'location)) - (slot-definition-location slotd) - default)) + (cond ((listp slotd) + (error "List instead of a slot definition object")) + (t + (slot-value slotd 'location)))) (defun unbound-slot-error (object index) (declare (type standard-object object) @@ -125,7 +126,7 @@ (setf (fdefinition name) gf) (fmakunbound alt-name))))) -(defun std-class-generate-accessors (standard-class &aux optimizable) +(defun std-class-generate-accessors (standard-class &optional (optimizable t)) ;; ;; The accessors are closures, which are generated every time the ;; slots of the class change. The accessors are safe: they check that @@ -134,15 +135,15 @@ ;; the instance. ;; (dolist (slotd (slot-value standard-class 'direct-slots)) - (multiple-value-bind (reader writer) - (let ((name (slot-definition-name slotd)) - (allocation (slot-definition-allocation slotd)) - (location (safe-slot-definition-location slotd))) + (with-slots ((name name) (allocation allocation) (location location) + (readers readers) (writers writers)) + slotd + (multiple-value-bind (reader writer) (cond ((and optimizable (eq allocation :instance) (typep location 'fixnum)) - (std-class-sealed-accessors (slot-definition-location slotd))) - ;; When a class is the specified STANDARD-CLASS, then the + (std-class-sealed-accessors location)) + ;; When a class is the of the specified STANDARD-CLASS, then the ;; user may not write any method around SLOT-VALUE-USING-CLASS ;; This allows us to write optimized versions of the accessors. ((and optimizable @@ -150,38 +151,40 @@ (eq standard-class +the-standard-class+)) (std-class-optimized-accessors name)) (t - (std-class-accessors name)))) - (let* ((reader-args (list :function reader - :generic-function nil - :qualifiers nil - :lambda-list '(object) - :specializers `(,standard-class) - :slot-definition slotd)) - (reader-class (if (boundp '*early-methods*) - 'standard-reader-method - (apply #'reader-method-class standard-class slotd - reader-args))) - (writer-args (list :function writer - :generic-function nil - :qualifiers nil - :lambda-list '(value object) - :specializers `(,(find-class t) ,standard-class) - :slot-definition slotd)) - (writer-class (if (boundp '*early-methods*) - 'standard-writer-method - (apply #'writer-method-class standard-class slotd - writer-args)))) - (dolist (fname (slot-definition-readers slotd)) - (safe-add-method fname - (make-method reader-class nil `(,standard-class) '(self) - (wrapped-method-function reader) - (list :slot-definition slotd)))) - (dolist (fname (slot-definition-writers slotd)) - (safe-add-method fname - (make-method writer-class nil - `(,(find-class t) ,standard-class) '(value self) - (wrapped-method-function writer) - (list :slot-definition slotd)))))))) + (std-class-accessors name))) + (let* ((reader-args (list :function reader + :generic-function nil + :qualifiers nil + :lambda-list '(object) + :specializers `(,standard-class) + :slot-definition slotd)) + (reader-class (if (boundp '*early-methods*) + 'standard-reader-method + (apply #'reader-method-class standard-class slotd + reader-args))) + (writer-args (list :function writer + :generic-function nil + :qualifiers nil + :lambda-list '(value object) + :specializers `(,(find-class t) ,standard-class) + :slot-definition slotd)) + (writer-class (if (boundp '*early-methods*) + 'standard-writer-method + (apply #'writer-method-class standard-class slotd + writer-args)))) + (dolist (fname readers) + (let ((method (make-method reader-class nil `(,standard-class) '(self) + (wrapped-method-function reader) + nil))) + (safe-add-method fname method) + (setf (slot-value method 'slot-definition) slotd))) + (dolist (fname writers) + (let ((method (make-method writer-class nil + `(,(find-class t) ,standard-class) '(value self) + (wrapped-method-function writer) + nil))) + (safe-add-method fname method) + (setf (slot-value method 'slot-definition) slotd)))))))) (defun reader-closure (index) (declare (si::c-local)) @@ -193,22 +196,20 @@ (labels ((generate-accessors (class) (declare (optimize speed (safety 0))) - #+(or) - (when (typep class 'standard-class) - (std-class-generate-accessors class)) - (loop for slotd in (slot-value class 'slots) - for index = (slot-definition-location slotd) - do (loop for reader in (slot-definition-readers slotd) - do (setf (fdefinition reader) (reader-closure index)) - #+(or) - (install-method reader nil (list class) '(self) - (reader-closure index) t)) - do (loop for writer in (slot-definition-writers slotd) - do (setf (fdefinition writer) (writer-closure index)) - #+(or) - (install-method writer nil (list +the-t-class+ class) - '(value self) - (writer-closure index) t))) + (if (and (typep class 'standard-class) + (not (member (slot-value class 'name) + '(slot-definition + direct-slot-definition + effective-slot-definition + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition)))) + (std-class-generate-accessors class t) + (loop for slotd in (slot-value class 'slots) + for index = (slot-value slotd 'location) + do (loop for reader in (slot-value slotd 'readers) + do (setf (fdefinition reader) (reader-closure index))) + do (loop for writer in (slot-value slotd 'writers) + do (setf (fdefinition writer) (writer-closure index))))) (mapc #'generate-accessors (slot-value class 'direct-subclasses)))) (generate-accessors +the-t-class+)) -