diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index 922b2b786..50bc5b0a7 100644 --- a/src/clos/boot.lsp +++ b/src/clos/boot.lsp @@ -371,7 +371,7 @@ (defun canonical-slots (slots) (declare (optimize speed (safety 0))) - (loop for s in (parse-slots (remove-accessors slots)) + (loop for s in (parse-slots slots) collect (canonical-slot-to-direct-slot nil s))) (defun add-slots (class slots) diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index bd0809158..b751d8115 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -129,43 +129,44 @@ (funcall (first primary) .combined-method-args. (rest primary))))) (defun standard-compute-effective-method (gf methods) - (let* ((before ()) - (primary ()) - (after ()) - (around ())) - (dolist (m methods) - (let* ((qualifiers (method-qualifiers m)) - (f (method-function m))) - (cond ((null qualifiers) (push f primary)) - ((rest qualifiers) (error-qualifier m qualifiers)) - ((eq (setq qualifiers (first qualifiers)) :BEFORE) - (push f before)) - ((eq qualifiers :AFTER) (push f after)) - ((eq qualifiers :AROUND) (push f around)) - (t (error-qualifier m qualifiers))))) - ;; When there are no primary methods, an error is to be signaled, - ;; and we need not care about :AROUND, :AFTER or :BEFORE methods. - (when (null primary) - (return-from standard-compute-effective-method - #'(lambda (&rest args) - (apply 'no-primary-method gf args)))) - ;; PRIMARY, BEFORE and AROUND are reversed because they have to - ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER - ;; may remain as it is because it is least-specific-order. - (setf primary (nreverse primary) - before (nreverse before)) - (if around - (let ((main (if (or before after) - (list - (standard-main-effective-method before primary after)) - primary))) - (setf around (nreverse around)) - (combine-method-functions (first around) - (nconc (rest around) main))) - (if (or before after) - (standard-main-effective-method before primary after) - (combine-method-functions (first primary) (rest primary)))) - )) + (with-early-accessors (+standard-method-slots+) + (let* ((before ()) + (primary ()) + (after ()) + (around ())) + (dolist (m methods) + (let* ((qualifiers (method-qualifiers m)) + (f (method-function m))) + (cond ((null qualifiers) (push f primary)) + ((rest qualifiers) (error-qualifier m qualifiers)) + ((eq (setq qualifiers (first qualifiers)) :BEFORE) + (push f before)) + ((eq qualifiers :AFTER) (push f after)) + ((eq qualifiers :AROUND) (push f around)) + (t (error-qualifier m qualifiers))))) + ;; When there are no primary methods, an error is to be signaled, + ;; and we need not care about :AROUND, :AFTER or :BEFORE methods. + (when (null primary) + (return-from standard-compute-effective-method + #'(lambda (&rest args) + (apply 'no-primary-method gf args)))) + ;; PRIMARY, BEFORE and AROUND are reversed because they have to + ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER + ;; may remain as it is because it is least-specific-order. + (setf primary (nreverse primary) + before (nreverse before)) + (if around + (let ((main (if (or before after) + (list + (standard-main-effective-method before primary after)) + primary))) + (setf around (nreverse around)) + (combine-method-functions (first around) + (nconc (rest around) main))) + (if (or before after) + (standard-main-effective-method before primary after) + (combine-method-functions (first primary) (rest primary)))) + ))) ;; ---------------------------------------------------------------------- ;; DEFINE-METHOD-COMBINATION @@ -334,11 +335,12 @@ (declare (type method-combination method-combination) (type generic-function gf) (optimize speed (safety 0))) - (let* ((compiler (method-combination-compiler method-combination)) - (options (method-combination-options method-combination))) - (if options - (apply compiler gf applicable-methods options) - (funcall compiler gf applicable-methods)))) + (with-early-accessors (+method-combination-slots+) + (let* ((compiler (method-combination-compiler method-combination)) + (options (method-combination-options method-combination))) + (if options + (apply compiler gf applicable-methods options) + (funcall compiler gf applicable-methods))))) (defun compute-effective-method-function (gf method-combination applicable-methods) ;; Cannot be inlined because it will be a method diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 7615102df..2025b0538 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -45,9 +45,7 @@ (map-into direct-slots #'identity new-direct-slots) (map-into effective-slots #'identity new-effective-slots) (when (typep class 'std-class) - (std-create-slots-table class) - ) - (std-class-generate-accessors class)) + (std-create-slots-table class))) (mapc #'convert-one-class (class-direct-subclasses class))) ;;; @@ -241,6 +239,13 @@ 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 (typep class 'standard-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 404bd9d27..d5a22506c 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -168,30 +168,33 @@ ;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with ;; a similar implementation in C (compute-discriminating-function gfun) - (set-funcallable-instance-function - gfun - (cond - ;; Case 1* - ((or (not optimizable) - (> (length (generic-function-spec-list gfun)) - si::c-arguments-limit)) - default-function) - ;; Case 2* - ((and (not (eq (class-id (class-of gfun)) 'standard-generic-function)) - *clos-booted*) - t) - ;; Cases 3* - ((loop with class = (find-class 'standard-reader-method nil) - for m in (generic-function-methods gfun) - 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) - always (eq class (class-of m))) - 'standard-writer-method) - ;; Case 4* - (t - 'standard-generic-function))))) + (let ((methods (generic-function-methods gfun))) + (set-funcallable-instance-function + gfun + (cond + ;; Case 1* + ((or (not optimizable) + (> (length (generic-function-spec-list gfun)) + si::c-arguments-limit)) + default-function) + ;; Case 2* + ((and (not (eq (class-id (class-of gfun)) '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) + 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) + always (eq class (class-of m))) + 'standard-writer-method) + ;; Case 4* + (t + 'standard-generic-function)))))) ;;; ---------------------------------------------------------------------- ;;; COMPUTE-APPLICABLE-METHODS @@ -218,7 +221,10 @@ (defun applicable-method-list (gf args) (declare (optimize (speed 3)) (si::c-local)) - (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+) + (with-early-accessors (+standard-method-slots+ + +standard-generic-function-slots+ + +eql-specializer-slots+ + +standard-class-slots+) (flet ((applicable-method-p (method args) (loop for spec in (method-specializers method) for arg in args diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 58d1d09c8..4c9da4aa2 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -39,7 +39,7 @@ (defun generic-function-method-class (generic-function) (if *clos-booted* (slot-value generic-function 'method-class) - 'standard-method)) + (find-class 'standard-method))) (defmacro defmethod (&whole whole name &rest args &environment env) (let* ((*print-length* 3) @@ -344,8 +344,12 @@ have disappeared." (defun make-method (method-class qualifiers specializers lambda-list fun options) (declare (ignore options)) - (with-early-make-instance +standard-method-slots+ - (method method-class + (with-early-make-instance + ;; We choose the largest list of slots + +standard-accessor-method-slots+ + (method (if (si::instancep method-class) + method-class + (find-class method-class)) :generic-function nil :lambda-list lambda-list :function fun @@ -360,7 +364,7 @@ have disappeared." ;;; early version used during bootstrap (defun add-method (gf method) - (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+) + (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+ +standard-class-slots+) (let* ((name (generic-function-name gf)) (method-entry (assoc name *early-methods*))) (unless method-entry diff --git a/src/clos/slotvalue.lsp b/src/clos/slotvalue.lsp index a3ca42d9a..9511fb6f1 100644 --- a/src/clos/slotvalue.lsp +++ b/src/clos/slotvalue.lsp @@ -32,26 +32,49 @@ (find slot-name (class-slots class) :key #'slot-definition-name))) (defun slot-value (self slot-name) - (let* ((class (class-of self)) - (slotd (find-slot-definition class slot-name))) - (if slotd - (slot-value-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-VALUE))))) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (let ((value (standard-instance-get self slotd))) + (if (sl:sl-boundp value) + value + (values (slot-unbound class self (slot-definition-name slotd))))) + (slot-missing class self slot-name 'SLOT-VALUE)))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-value-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-VALUE))))))) (defun slot-boundp (self slot-name) - (let* ((class (class-of self)) - (slotd (find-slot-definition class slot-name))) - (if slotd - (slot-boundp-using-class class self slotd) - (values (slot-missing class self slot-name 'SLOT-BOUNDP))))) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (si::sl-boundp (standard-instance-get self slotd)) + (values (slot-missing class self slot-name 'SLOT-BOUNDP))))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (slot-boundp-using-class class self slotd) + (values (slot-missing class self slot-name 'SLOT-BOUNDP))))))) (defun (setf slot-value) (value self slot-name) - (let* ((class (class-of self)) - (slotd (find-slot-definition class slot-name))) - (if slotd - (funcall #'(setf slot-value-using-class) value class self slotd) - (slot-missing class self slot-name 'SETF value)) - value)) + (let* ((class (class-of self))) + (if (or (eq (si:instance-class class) +the-standard-class+) + (eq (si:instance-class class) +the-funcallable-standard-class+)) + (with-early-accessors (+standard-class-slots+) + (let ((slotd (gethash slot-name (slot-table class) nil))) + (if slotd + (standard-instance-set value self slotd) + (slot-missing class self slot-name 'SETF value)))) + (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) + (if slotd + (setf (slot-value-using-class class self slotd) value) + (slot-missing class self slot-name 'SETF value)))))) (defun slot-makunbound (self slot-name) (let* ((class (class-of self)) @@ -70,31 +93,33 @@ ;;; (defun standard-instance-get (instance slotd) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (location (slot-definition-location slotd))) - (cond ((ext:fixnump location) - ;; local slot - (si:instance-ref instance (truly-the fixnum location))) - ((consp location) - ;; shared slot - (car location)) - (t - (invalid-slot-definition instance slotd))))) + (with-early-accessors (+standard-class-slots+) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((ext:fixnump location) + ;; local slot + (si:instance-ref instance (truly-the fixnum location))) + ((consp location) + ;; shared slot + (car location)) + (t + (invalid-slot-definition instance slotd)))))) (defun standard-instance-set (val instance slotd) - (ensure-up-to-date-instance instance) - (let* ((class (si:instance-class instance)) - (location (slot-definition-location slotd))) - (cond ((ext:fixnump location) - ;; local slot - (si:instance-set instance (truly-the fixnum location) val)) - ((consp location) - ;; shared slot - (setf (car location) val)) - (t - (invalid-slot-definition instance slotd)))) - val) + (with-early-accessors (+standard-class-slots+) + (ensure-up-to-date-instance instance) + (let* ((class (si:instance-class instance)) + (location (slot-definition-location slotd))) + (cond ((ext:fixnump location) + ;; local slot + (si:instance-set instance (truly-the fixnum location) val)) + ((consp location) + ;; shared slot + (setf (car location) val)) + (t + (invalid-slot-definition instance slotd)))) + val)) (defun invalid-slot-definition (instance slotd) (error "Effective slot definition lacks a valid location. @@ -138,12 +163,10 @@ Slot name: ~A" (defmethod slot-missing ((class t) object slot-name operation &optional new-value) (declare (ignore operation new-value class)) - (print (list 'slot-missing slot-name (class-id class))) (error "~A is not a slot of ~A" slot-name object)) (defmethod slot-unbound ((class t) object slot-name) (declare (ignore class)) - (print (list 'slot-unbound (class-id class) (print slot-name))) (error 'unbound-slot :instance object :name slot-name)) ;;; diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index faf76a8eb..6d290c702 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -111,9 +111,9 @@ ;; be (:allow-other-keys t), which disables the checking of the arguments. ;; (Paul Dietz's ANSI test suite, test CLASS-24.4) (setf initargs (add-default-initargs class initargs)) - (let ((keywords (class-valid-initargs class))) - (when (eq keywords (si::unbound)) - (setf keywords (precompute-valid-initarg-keywords class))) + (let ((keywords (if (slot-boundp class 'valid-initargs) + (class-valid-initargs class) + (precompute-valid-initarg-keywords class)))) (check-initargs class initargs nil (class-slots class) keywords)) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) @@ -304,7 +304,8 @@ because it contains a reference to the undefined class~% ~A" ;; their locations. This may imply adding _new_ direct slots. ;; (when (class-sealedp class) - (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class))))) + (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class)))) + (all-slots (class-slots class))) ;; ;; We first search all slots that belonged to unsealed classes and which ;; therefore have no fixed position. @@ -318,9 +319,10 @@ because it contains a reference to the undefined class~% ~A" ;; the class direct slots. ;; (loop for slotd in (class-direct-slots class) - do (let ((name (slot-definition-name slotd))) + do (let* ((name (slot-definition-name slotd)) + (other-slotd (find name all-slots :key #'slot-definition-name))) (setf (slot-definition-location slotd) - (slot-definition-location (find-slot-definition class name)) + (slot-definition-location other-slotd) free-slots (delete name free-slots)))) ;; ;; And finally we add one direct slot for each inherited slot that did @@ -328,7 +330,7 @@ because it contains a reference to the undefined class~% ~A" ;; (loop for name in free-slots with direct-slots = (class-direct-slots class) - do (let* ((effective-slotd (find-slot-definition class name)) + do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name)) (def (loop for (name . rest) in +slot-definition-slots+ nconc (list (getf rest :initarg) (funcall (getf rest :accessor) effective-slotd))))) @@ -710,9 +712,9 @@ because it contains a reference to the undefined class~% ~A" :specializers `(,(find-class t) ,standard-class) :slot-definition slotd)) (writer-class (if (boundp '*early-methods*) - 'standard-reader-method - (apply #'writer-method-class standard-class slotd - writer-args)))) + '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)