diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 6f7b7898ad98571317e822f44f4d95b666389168..e8294b6a0998cae9049965391c3c14ab9e55d6c5 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.26 2003/03/26 17:15:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.27 2003/04/25 17:43:50 gerd Exp $") (in-package :pcl) @@ -742,7 +742,48 @@ *standard-method-combination*)) type))))) -(defun get-accessor-method-function (gf type class slotd) +;;; +;;; Called from COMPUTE-DISCRIMINATING-FUNCTION for +;;; SLOT-VALUE-USING-CLASS, (SETF SLOT-VALUE-USING-CLASS) and +;;; SLOT-BOUNDP-USING-CLASS. GF is one of these functions, TYPE is +;;; one of the symbols READER, WRITER, or BOUNDP. +;;; +;;; Note that these gfs have unusual, fixed dispatch functions calling +;;; effective methods stored in effective slot definitions, which are +;;; set in COMPUTE-SLOT-ACCESSOR-INFO. +;;; +;;; FIXME: It looks to me like *NEW-CLASS* could be deleted, but +;;; I'm not 100% sure. +;;; +(defun update-slot-value-gf-info (gf type) + (unless *new-class* + (update-std-or-str-methods gf type)) + (when (and (standard-svuc-method type) + (structure-svuc-method type)) + (flet ((update-class (class) + (when (class-finalized-p class) + (dolist (slotd (class-slots class)) + (compute-slot-accessor-info slotd type gf))))) + (if *new-class* + (update-class *new-class*) + (map-all-classes #'update-class 'slot-object))))) + +;;; +;;; Return two values. First value is a function to be stored in +;;; effective slot definition SLOTD for reading it with +;;; SLOT-VALUE-USING-CLASS, setting it with (SETF +;;; SLOT-VALUE-USING-CLASS) or testing it with +;;; SLOT-BOUNDP-USING-CLASS. GF is one of these generic functions, +;;; TYPE is one of the symbols READER, WRITER, BOUNDP. CLASS is +;;; SLOTD's class. +;;; +;;; Second value is true if the function returned is one of the +;;; optimized standard functions for the purpose, which are used +;;; when only standard methods are applicable. +;;; +;;; FIXME: Change all these wacky function names to something sane. +;;; +(defun get-accessor-method-function (gf type class slotd) (let* ((std-method (standard-svuc-method type)) (str-method (structure-svuc-method type)) (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) @@ -752,41 +793,63 @@ (values (if std-p (get-optimized-std-accessor-method-function class slotd type) - (get-accessor-from-svuc-method-function - class slotd - (get-secondary-dispatch-function - gf methods types - `((,(car (or (member std-method methods) - (member str-method methods) - (internal-error "In get-accessor-method-function."))) - ,(get-optimized-std-slot-value-using-class-method-function - class slotd type))) - (unless (and (eq type 'writer) - (dolist (method methods t) - (unless (eq (car (method-specializers method)) - *the-class-t*) - (return nil)))) - (let ((wrappers (list (wrapper-of class) - (class-wrapper class) - (wrapper-of slotd)))) - (if (eq type 'writer) - (cons (class-wrapper *the-class-t*) wrappers) - wrappers)))) - type)) + (let* ((optimized-std-fn + (get-optimized-std-slot-value-using-class-method-function + class slotd type)) + (method-alist + `((,(car (or (member std-method methods) + (member str-method methods) + (internal-error "In get-accessor-method-function."))) + ,optimized-std-fn))) + (wrappers + ;; + ;; This used to be wrapped in + ;; + ;; (unless (and (eq type 'writer) + ;; (every (lambda (x) + ;; (eq (car (method-specializers x)) + ;; *the-class-t*)) + ;; methods)) + ;; + ;; but that looks wrong because WRAPPERS nil signals + ;; to GET-SECONDARY-DISPATCH-FUNCTION that we are NOT + ;; generating code for an emf, which is wrong because + ;; we are. + ;; + ;; See the message from Kevin Rosenberg <kevin@rosenberg.net> + ;; to cmucl-imp from Tue, 22 Apr 2003 13:28:23 -0600 + ;; and the following thread for a test case where this + ;; causes problems. + ;; + ;; gerd, 2003-04-25 + (let ((wrappers (list (wrapper-of class) + (class-wrapper class) + (wrapper-of slotd)))) + (if (eq type 'writer) + (cons (class-wrapper *the-class-t*) wrappers) + wrappers))) + (sdfun (get-secondary-dispatch-function + gf methods types method-alist wrappers))) + (get-accessor-from-svuc-method-function class slotd sdfun type))) std-p))) -;used by optimize-slot-value-by-class-p (vector.lisp) -(defun update-slot-value-gf-info (gf type) - (unless *new-class* - (update-std-or-str-methods gf type)) - (when (and (standard-svuc-method type) (structure-svuc-method type)) - (flet ((update-class (class) - (when (class-finalized-p class) - (dolist (slotd (class-slots class)) - (compute-slot-accessor-info slotd type gf))))) - (if *new-class* - (update-class *new-class*) - (map-all-classes #'update-class 'slot-object))))) +(defun get-accessor-from-svuc-method-function (class slotd sdfun name) + (macrolet ((emf-funcall (emf &rest args) + `(invoke-effective-method-function ,emf nil ,@args))) + (let ((function + (ecase 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)))))) + (set-function-name function `(,name ,(class-name class) + ,(slot-definition-name slotd))) + function))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) @@ -1433,21 +1496,12 @@ (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) - #|| (name (generic-function-name gf)) ||# (arg-info (gf-arg-info gf))) - (cond #|| - ((eq name 'slot-value-using-class) - (update-slot-value-gf-info gf 'reader)) - ((equal name '(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer)) - ((eq name 'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp)) - ||# - ((gf-precompute-dfun-and-emf-p arg-info) - (multiple-value-bind (dfun cache info) - (make-final-dfun-internal gf) - (set-dfun gf dfun cache info) ; otherwise cache might get freed twice - (update-dfun gf dfun cache info)))))) + (when (gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (dfun cache info) + (make-final-dfun-internal gf) + (set-dfun gf dfun cache info) + (update-dfun gf dfun cache info))))) ;;; ;;; diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index c29de10ef04eca1ca2f0d83717652d535e6a44f2..b5846ba7efdd7be344e06b1823cf92edc2993fc8 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.18 2003/03/26 17:15:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.19 2003/04/25 17:43:50 gerd Exp $") ;;; (in-package :pcl) @@ -328,16 +328,6 @@ (check-obsolete-instance instance) (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)))) - `(,name ,(class-name class) ,(slot-definition-name slotd))))) - (defun make-internal-reader-method-function (class-name slot-name) (list* :method-spec `(internal-reader-method ,class-name ,slot-name) (make-method-function diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index ef9ac4f69ef05c07e46ff3d2d8351f5d0a71c191..2bf7abb58edf25fa3b408f5b03c378b2d3a3fa3b 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.53 2003/04/18 10:06:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.54 2003/04/25 17:43:50 gerd Exp $") (in-package :pcl) @@ -89,6 +89,20 @@ (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) +;;; +;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF +;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/ +;;; writing/testing effective slot SLOTD. +;;; +;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on +;;; GF. Store the effective method in the effective slot definition +;;; object itself; these GFs have special dispatch functions calling +;;; effective methods directly retrieved from effective slot +;;; definition objects, as an optimization. +;;; +;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, +;;; or some such. +;;; (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) @@ -101,8 +115,6 @@ (get-optimized-std-accessor-method-function class slotd type)) (setf (slot-accessor-std-p slotd type) std-p) (setf (slot-accessor-function slotd type) function)) - ;; - ;; Optimized accessor functions use pv tables. (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) (record-pv-update-info slotd)))) @@ -883,20 +895,10 @@ ;;; ;;; (defmethod compute-default-initargs ((class slot-class)) - (let ((cpl (class-precedence-list class)) - (direct (class-direct-default-initargs class))) - (labels ((walk (tail) - (if (null tail) - nil - (let ((c (pop tail))) - (append (if (eq c class) - direct - (class-direct-default-initargs c)) - (walk tail)))))) - (let ((initargs (walk cpl))) - (delete-duplicates initargs :test #'eq :key #'car :from-end t))))) + (let ((initargs (loop for c in (class-precedence-list class) + append (class-direct-default-initargs c)))) + (delete-duplicates initargs :test #'eq :key #'car :from-end t))) - ;;; ;;; Protocols for constructing direct and effective slot definitions. ;;;