From: William Harold Newman Date: Thu, 14 Jul 2005 19:45:31 +0000 (+0000) Subject: 0.9.2.50: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git 0.9.2.50: another slice of whitespace canonicalization (Anyone who ends up here with "cvs annotate" probably wants to look at the "tabby" tagged version.) --- diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 40a922a..8b55efa 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -41,22 +41,22 @@ class initargs (append (compute-applicable-methods #'allocate-instance (list class)) - (compute-applicable-methods + (compute-applicable-methods #'initialize-instance (list class-proto)) - (compute-applicable-methods + (compute-applicable-methods #'shared-initialize (list class-proto t))))))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance))) (defmethod default-initargs ((class slot-class) - supplied-initargs - class-default-initargs) + supplied-initargs + class-default-initargs) (loop for (key nil fun) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) - append (list key (funcall fun)) into default-initargs + append (list key (funcall fun)) into default-initargs finally - (return (append supplied-initargs default-initargs)))) + (return (append supplied-initargs default-initargs)))) (defmethod initialize-instance ((instance slot-object) &rest initargs) (apply #'shared-initialize instance t initargs)) @@ -69,35 +69,35 @@ instance) (defmethod update-instance-for-different-class ((previous std-object) - (current std-object) - &rest initargs) + (current std-object) + &rest initargs) ;; First we must compute the newly added slots. The spec defines ;; newly added slots as "those local slots for which no slot of ;; the same name exists in the previous class." (let ((added-slots '()) - (current-slotds (class-slots (class-of current))) - (previous-slot-names (mapcar #'slot-definition-name - (class-slots (class-of previous))))) + (current-slotds (class-slots (class-of current))) + (previous-slot-names (mapcar #'slot-definition-name + (class-slots (class-of previous))))) (dolist (slotd current-slotds) (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) - (eq (slot-definition-allocation slotd) :instance)) - (push (slot-definition-name slotd) added-slots))) + (eq (slot-definition-allocation slotd) :instance)) + (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs (list (list* 'update-instance-for-different-class previous current initargs) - (list* 'shared-initialize current added-slots initargs))) + (list* 'shared-initialize current added-slots initargs))) (apply #'shared-initialize current added-slots initargs))) (defmethod update-instance-for-redefined-class ((instance std-object) - added-slots - discarded-slots - property-list - &rest initargs) + added-slots + discarded-slots + property-list + &rest initargs) (check-initargs-1 (class-of instance) initargs (list (list* 'update-instance-for-redefined-class - instance added-slots discarded-slots property-list initargs) - (list* 'shared-initialize instance added-slots initargs))) + instance added-slots discarded-slots property-list initargs) + (list* 'shared-initialize instance added-slots initargs))) (apply #'shared-initialize instance added-slots initargs)) (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) @@ -111,71 +111,71 @@ (initialize-slot-from-initfunction (class instance slotd) ;; CLHS: If a before method stores something in a slot, ;; that slot won't be initialized from its :INITFORM, if any. - (if (typep instance 'structure-object) - (when (eq (funcall - ;; not SLOT-VALUE-USING-CLASS, as that - ;; throws an error if the value is the - ;; unbound marker. - (slot-definition-internal-reader-function slotd) - instance) - +slot-unbound+) - (setf (slot-value-using-class class instance slotd) - (let ((initfn (slot-definition-initfunction slotd))) - (when initfn - (funcall initfn))))) - (unless (or (null (slot-definition-initfunction slotd)) - (slot-boundp-using-class class instance slotd)) - (setf (slot-value-using-class class instance slotd) - (funcall (slot-definition-initfunction slotd))))))) + (if (typep instance 'structure-object) + (when (eq (funcall + ;; not SLOT-VALUE-USING-CLASS, as that + ;; throws an error if the value is the + ;; unbound marker. + (slot-definition-internal-reader-function slotd) + instance) + +slot-unbound+) + (setf (slot-value-using-class class instance slotd) + (let ((initfn (slot-definition-initfunction slotd))) + (when initfn + (funcall initfn))))) + (unless (or (null (slot-definition-initfunction slotd)) + (slot-boundp-using-class class instance slotd)) + (setf (slot-value-using-class class instance slotd) + (funcall (slot-definition-initfunction slotd))))))) (let* ((class (class-of instance)) (initfn-slotds (loop for slotd in (class-slots class) unless (initialize-slot-from-initarg class instance slotd) collect slotd))) (dolist (slotd initfn-slotds) - (if (eq (slot-definition-allocation slotd) :class) - (when (or (eq t slot-names) - (memq (slot-definition-name slotd) slot-names)) - (unless (slot-boundp-using-class class instance slotd) - (initialize-slot-from-initfunction class instance slotd))) - (when (or (eq t slot-names) - (memq (slot-definition-name slotd) slot-names)) - (initialize-slot-from-initfunction class instance slotd))))) + (if (eq (slot-definition-allocation slotd) :class) + (when (or (eq t slot-names) + (memq (slot-definition-name slotd) slot-names)) + (unless (slot-boundp-using-class class instance slotd) + (initialize-slot-from-initfunction class instance slotd))) + (when (or (eq t slot-names) + (memq (slot-definition-name slotd) slot-names)) + (initialize-slot-from-initfunction class instance slotd))))) instance)) ;;; If initargs are valid return nil, otherwise signal an error. (defun check-initargs-1 (class initargs call-list - &optional (plist-p t) (error-p t)) + &optional (plist-p t) (error-p t)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class call-list) (unless allow-other-keys (if plist-p - (check-initargs-2-plist initargs class legal error-p) - (check-initargs-2-list initargs class legal error-p))))) + (check-initargs-2-plist initargs class legal error-p) + (check-initargs-2-list initargs class legal error-p))))) (defun check-initargs-values (class call-list) (let ((methods (mapcan (lambda (call) - (if (consp call) - (copy-list (compute-applicable-methods - (gdefinition (car call)) - (cdr call))) - (list call))) - call-list)) - (legal (apply #'append (mapcar #'slot-definition-initargs - (class-slots class))))) + (if (consp call) + (copy-list (compute-applicable-methods + (gdefinition (car call)) + (cdr call))) + (list call))) + call-list)) + (legal (apply #'append (mapcar #'slot-definition-initargs + (class-slots class))))) ;; Add to the set of slot-filling initargs the set of ;; initargs that are accepted by the methods. If at ;; any point we come across &allow-other-keys, we can ;; just quit. (dolist (method methods) (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) - (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) - (declare (ignore nreq nopt keysp restp)) - (when allow-other-keys - (return-from check-initargs-values (values nil t))) - (setq legal (append keys legal)))) + (analyze-lambda-list (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (declare (ignore nreq nopt keysp restp)) + (when allow-other-keys + (return-from check-initargs-values (values nil t))) + (setq legal (append keys legal)))) (values legal nil))) (define-condition initarg-error (reference-condition program-error) @@ -183,11 +183,11 @@ (initargs :reader initarg-error-initargs :initarg :initargs)) (:default-initargs :references (list '(:ansi-cl :section (7 1 2)))) (:report (lambda (condition stream) - (format stream "~@~I~_in call for class ~S.~:>" - (length (initarg-error-initargs condition)) - (list (initarg-error-initargs condition)) - (initarg-error-class condition))))) + (length (initarg-error-initargs condition)) + (list (initarg-error-initargs condition)) + (initarg-error-class condition))))) (defun check-initargs-2-plist (initargs class legal &optional (error-p t)) (let ((invalid-keys ())) @@ -195,12 +195,12 @@ ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (doplist (key val) initargs - (unless (or (memq key legal) - ;; :ALLOW-OTHER-KEYS NIL gets here - (eq key :allow-other-keys)) - (push key invalid-keys))) + (unless (or (memq key legal) + ;; :ALLOW-OTHER-KEYS NIL gets here + (eq key :allow-other-keys)) + (push key invalid-keys))) (when (and invalid-keys error-p) - (error 'initarg-error :class class :initargs invalid-keys))) + (error 'initarg-error :class class :initargs invalid-keys))) invalid-keys)) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) @@ -209,9 +209,9 @@ ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (dolist (key initkeys) - (unless (memq key legal) - (push key invalid-keys))) + (unless (memq key legal) + (push key invalid-keys))) (when (and invalid-keys error-p) - (error 'initarg-error :class class :initargs invalid-keys))) + (error 'initarg-error :class class :initargs invalid-keys))) invalid-keys)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 76aa2b8..8105d2d 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -58,18 +58,18 @@ ;;; this shouldn't matter, since the only two slots that WRAPPER adds ;;; are meaningless in those cases. (defstruct (wrapper - (:include layout - ;; KLUDGE: In CMU CL, the initialization default - ;; for LAYOUT-INVALID was NIL. In SBCL, that has - ;; changed to :UNINITIALIZED, but PCL code might - ;; still expect NIL for the initialization - ;; default of WRAPPER-INVALID. Instead of trying - ;; to find out, I just overrode the LAYOUT - ;; default here. -- WHN 19991204 - (invalid nil)) - (:conc-name %wrapper-) - (:constructor make-wrapper-internal) - (:copier nil)) + (:include layout + ;; KLUDGE: In CMU CL, the initialization default + ;; for LAYOUT-INVALID was NIL. In SBCL, that has + ;; changed to :UNINITIALIZED, but PCL code might + ;; still expect NIL for the initialization + ;; default of WRAPPER-INVALID. Instead of trying + ;; to find out, I just overrode the LAYOUT + ;; default here. -- WHN 19991204 + (invalid nil)) + (:conc-name %wrapper-) + (:constructor make-wrapper-internal) + (:copier nil)) (instance-slots-layout nil :type list) (class-slots nil :type list)) #-sb-fluid (declaim (sb-ext:freeze-type wrapper)) @@ -134,13 +134,13 @@ ;; a temporary definition used for debugging the bootstrap #+sb-show (defun print-std-instance (instance stream depth) - (declare (ignore depth)) + (declare (ignore depth)) (print-unreadable-object (instance stream :type t :identity t) (let ((class (class-of instance))) (when (or (eq class (find-class 'standard-class nil)) - (eq class (find-class 'funcallable-standard-class nil)) - (eq class (find-class 'built-in-class nil))) - (princ (early-class-name instance) stream))))) + (eq class (find-class 'funcallable-standard-class nil)) + (eq class (find-class 'built-in-class nil))) + (princ (early-class-name instance) stream))))) ;;; This is the value that we stick into a slot to tell us that it is ;;; unbound. It may seem gross, but for performance reasons, we make @@ -181,10 +181,10 @@ (setq fun (fdefinition fun))) (when (funcallable-instance-p fun) (if (if (eq *boot-state* 'complete) - (typep fun 'generic-function) - (eq (class-of fun) *the-class-standard-generic-function*)) - (setf (%funcallable-instance-info fun 1) new-name) - (bug "unanticipated function type"))) + (typep fun 'generic-function) + (eq (class-of fun) *the-class-standard-generic-function*)) + (setf (%funcallable-instance-info fun 1) new-name) + (bug "unanticipated function type"))) ;; Fixup name-to-function mappings in cases where the function ;; hasn't been defined by DEFUN. (FIXME: is this right? This logic ;; comes from CMUCL). -- CSR, 2004-12-31 @@ -212,12 +212,12 @@ ;;; we make it, and we want the accessor to still be type-correct. #| (defstruct (standard-instance - (:predicate nil) - (:constructor %%allocate-instance--class ()) - (:copier nil) - (:alternate-metaclass instance - cl:standard-class - make-standard-class)) + (:predicate nil) + (:constructor %%allocate-instance--class ()) + (:copier nil) + (:alternate-metaclass instance + cl:standard-class + make-standard-class)) (slots nil)) |# (!defstruct-with-alternate-metaclass standard-instance @@ -269,8 +269,8 @@ (defmacro get-instance-wrapper-or-nil (inst) (once-only ((wrapper `(wrapper-of ,inst))) `(if (typep ,wrapper 'wrapper) - ,wrapper - nil))) + ,wrapper + nil))) ;;;; support for useful hashing of PCL instances @@ -285,7 +285,7 @@ ;; Hopefully there was no virtue to the old counter implementation ;; that I am insufficiently insightful to insee. -- WHN 2004-10-28 (random most-positive-fixnum - *instance-hash-code-random-state*)) + *instance-hash-code-random-state*)) (defun sb-impl::sxhash-instance (x) (cond @@ -307,14 +307,14 @@ (defun structure-type-included-type-name (type) (let ((include (dd-include (get-structure-dd type)))) (if (consp include) - (car include) - include))) + (car include) + include))) (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) - (and include - (dd-slots (get-structure-dd include))))) - (dd-slots (get-structure-dd type)))) + (and include + (dd-slots (get-structure-dd include))))) + (dd-slots (get-structure-dd type)))) (defun structure-slotd-name (slotd) (dsd-name slotd)) @@ -328,7 +328,7 @@ (defun structure-slotd-writer-function (type slotd) (if (dsd-read-only slotd) (let ((dd (get-structure-dd type))) - (coerce (slot-setter-lambda-form dd slotd) 'function)) + (coerce (slot-setter-lambda-form dd slotd) 'function)) (fdefinition `(setf ,(dsd-accessor-name slotd))))) (defun structure-slotd-type (slotd) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 296aeb4..4aa875b 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -29,18 +29,18 @@ (/show "starting pcl/macros.lisp") (declaim (declaration - ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration - ;; to propagate information needed to set up nice debug - ;; names (as seen e.g. in BACKTRACE) for method functions. - %method-name - ;; These nonstandard declarations seem to be used privately - ;; within PCL itself to pass information around, so we can't - ;; just delete them. - %class - %method-lambda-list - ;; This declaration may also be used within PCL to pass - ;; information around, I'm not sure. -- WHN 2000-12-30 - %variable-rebinding)) + ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration + ;; to propagate information needed to set up nice debug + ;; names (as seen e.g. in BACKTRACE) for method functions. + %method-name + ;; These nonstandard declarations seem to be used privately + ;; within PCL itself to pass information around, so we can't + ;; just delete them. + %class + %method-lambda-list + ;; This declaration may also be used within PCL to pass + ;; information around, I'm not sure. -- WHN 2000-12-30 + %variable-rebinding)) (/show "done with DECLAIM DECLARATION") @@ -48,30 +48,30 @@ (dolist (d declarations default) (dolist (form (cdr d)) (when (and (consp form) (eq (car form) name)) - (return-from get-declaration (cdr form)))))) + (return-from get-declaration (cdr form)))))) (/show "pcl/macros.lisp 85") (defmacro doplist ((key val) plist &body body) `(let ((.plist-tail. ,plist) ,key ,val) (loop (when (null .plist-tail.) (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "malformed plist, odd number of elements")) - (setq ,val (pop .plist-tail.)) - (progn ,@body)))) + (setq ,key (pop .plist-tail.)) + (when (null .plist-tail.) + (error "malformed plist, odd number of elements")) + (setq ,val (pop .plist-tail.)) + (progn ,@body)))) (/show "pcl/macros.lisp 101") (defmacro dolist-carefully ((var list improper-list-handler) &body body) `(let ((,var nil) - (.dolist-carefully. ,list)) + (.dolist-carefully. ,list)) (loop (when (null .dolist-carefully.) (return nil)) - (if (consp .dolist-carefully.) - (progn - (setq ,var (pop .dolist-carefully.)) - ,@body) - (,improper-list-handler))))) + (if (consp .dolist-carefully.) + (progn + (setq ,var (pop .dolist-carefully.)) + ,@body) + (,improper-list-handler))))) ;;;; FIND-CLASS ;;;; @@ -94,9 +94,9 @@ (defun find-class-cell (symbol &optional dont-create-p) (or (gethash symbol *find-class*) (unless dont-create-p - (unless (legal-class-name-p symbol) - (error "~S is not a legal class name." symbol)) - (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) + (unless (legal-class-name-p symbol) + (error "~S is not a legal class name." symbol)) + (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) (/show "pcl/macros.lisp 157") @@ -105,13 +105,13 @@ (defun find-class-from-cell (symbol cell &optional (errorp t)) (or (find-class-cell-class cell) (and *create-classes-from-internal-structure-definitions-p* - (or (structure-type-p symbol) (condition-type-p symbol)) - (ensure-non-standard-class symbol)) + (or (structure-type-p symbol) (condition-type-p symbol)) + (ensure-non-standard-class symbol)) (cond ((null errorp) nil) - ((legal-class-name-p symbol) - (error "There is no class named ~S." symbol)) - (t - (error "~S is not a legal class name." symbol))))) + ((legal-class-name-p symbol) + (error "There is no class named ~S." symbol)) + (t + (error "~S is not a legal class name." symbol))))) (defun find-class-predicate-from-cell (symbol cell &optional (errorp t)) (unless (find-class-cell-class cell) @@ -124,14 +124,14 @@ (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-from-cell symbol - (find-class-cell symbol errorp) - errorp)) + (find-class-cell symbol errorp) + errorp)) (defun find-class-predicate (symbol &optional (errorp t) environment) (declare (ignore environment)) (find-class-predicate-from-cell symbol - (find-class-cell symbol errorp) - errorp)) + (find-class-cell symbol errorp) + errorp)) ;;; This DEFVAR was originally in defs.lisp, now moved here. ;;; @@ -144,44 +144,44 @@ (/show "pcl/macros.lisp 187") (define-compiler-macro find-class (&whole form - symbol &optional (errorp t) environment) + symbol &optional (errorp t) environment) (declare (ignore environment)) (if (and (constantp symbol) - (legal-class-name-p (eval symbol)) - (constantp errorp) - (member *boot-state* '(braid complete))) + (legal-class-name-p (eval symbol)) + (constantp errorp) + (member *boot-state* '(braid complete))) (let ((symbol (eval symbol)) - (errorp (not (null (eval errorp)))) - (class-cell (make-symbol "CLASS-CELL"))) - `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) - (or (find-class-cell-class ,class-cell) - ,(if errorp - `(find-class-from-cell ',symbol ,class-cell t) - `(and (classoid-cell-classoid - ',(find-classoid-cell symbol)) - (find-class-from-cell ',symbol ,class-cell nil)))))) + (errorp (not (null (eval errorp)))) + (class-cell (make-symbol "CLASS-CELL"))) + `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) + (or (find-class-cell-class ,class-cell) + ,(if errorp + `(find-class-from-cell ',symbol ,class-cell t) + `(and (classoid-cell-classoid + ',(find-classoid-cell symbol)) + (find-class-from-cell ',symbol ,class-cell nil)))))) form)) (defun (setf find-class) (new-value name &optional errorp environment) (declare (ignore errorp environment)) (cond ((legal-class-name-p name) - (with-single-package-locked-error - (:symbol name "using ~A as the class-name argument in ~ + (with-single-package-locked-error + (:symbol name "using ~A as the class-name argument in ~ (SETF FIND-CLASS)")) - (let ((cell (find-class-cell name))) - (setf (find-class-cell-class cell) new-value) - (when (and (eq *boot-state* 'complete) (null new-value)) - (setf (find-classoid name) nil)) - (when (or (eq *boot-state* 'complete) - (eq *boot-state* 'braid)) - (when (and new-value (class-wrapper new-value) + (let ((cell (find-class-cell name))) + (setf (find-class-cell-class cell) new-value) + (when (and (eq *boot-state* 'complete) (null new-value)) + (setf (find-classoid name) nil)) + (when (or (eq *boot-state* 'complete) + (eq *boot-state* 'braid)) + (when (and new-value (class-wrapper new-value) (class-predicate-name new-value)) - (setf (find-class-cell-predicate cell) - (fdefinition (class-predicate-name new-value)))) - (update-ctors 'setf-find-class :class new-value :name name)) - new-value)) - (t - (error "~S is not a legal class name." name)))) + (setf (find-class-cell-predicate cell) + (fdefinition (class-predicate-name new-value)))) + (update-ctors 'setf-find-class :class new-value :name name)) + new-value)) + (t + (error "~S is not a legal class name." name)))) (/show "pcl/macros.lisp 230") diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d956759..140115a 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -30,15 +30,15 @@ ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-FUNCTION -;;; METHOD-FUNCTION ?? +;;; METHOD-FUNCTION ?? (defmethod method-function ((method standard-method)) (or (slot-value method 'function) (let ((fmf (slot-value method 'fast-function))) - (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. - (error "~S doesn't seem to have a METHOD-FUNCTION." method)) - (setf (slot-value method 'function) - (method-function-from-fast-function fmf))))) + (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this. + (error "~S doesn't seem to have a METHOD-FUNCTION." method)) + (setf (slot-value method 'function) + (method-function-from-fast-function fmf))))) (defmethod accessor-method-class ((method standard-accessor-method)) (car (slot-value method 'specializers))) @@ -56,8 +56,8 @@ (defmethod reinitialize-instance ((method standard-method) &rest initargs) (declare (ignore initargs)) (error "An attempt was made to reinitialize the method ~S.~%~ - Method objects cannot be reinitialized." - method)) + Method objects cannot be reinitialized." + method)) (defmethod legal-documentation-p ((object standard-method) x) (if (or (null x) (stringp x)) @@ -75,12 +75,12 @@ (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () - (return-from legal-qualifiers-p "Is not a proper list."))) + (return-from legal-qualifiers-p "Is not a proper list."))) (dolist-carefully (q x improper-list) (let ((ok (legal-qualifier-p object q))) - (unless (eq ok t) - (return-from legal-qualifiers-p - (format nil "Contains ~S which ~A" q ok))))) + (unless (eq ok t) + (return-from legal-qualifiers-p + (format nil "Contains ~S which ~A" q ok))))) t)) (defmethod legal-qualifier-p ((object standard-method) x) @@ -90,92 +90,92 @@ (defmethod legal-slot-name-p ((object standard-method) x) (cond ((not (symbolp x)) "is not a symbol") - (t t))) + (t t))) (defmethod legal-specializers-p ((object standard-method) x) (flet ((improper-list () - (return-from legal-specializers-p "Is not a proper list."))) + (return-from legal-specializers-p "Is not a proper list."))) (dolist-carefully (s x improper-list) (let ((ok (legal-specializer-p object s))) - (unless (eq ok t) - (return-from legal-specializers-p - (format nil "Contains ~S which ~A" s ok))))) + (unless (eq ok t) + (return-from legal-specializers-p + (format nil "Contains ~S which ~A" s ok))))) t)) (defvar *allow-experimental-specializers-p* nil) (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* - (specializerp x) - (or (classp x) - (eql-specializer-p x))) + (specializerp x) + (or (classp x) + (eql-specializer-p x))) t "is neither a class object nor an EQL specializer")) (defmethod shared-initialize :before ((method standard-method) - slot-names - &key qualifiers - lambda-list - specializers - function - fast-function - documentation) + slot-names + &key qualifiers + lambda-list + specializers + function + fast-function + documentation) (declare (ignore slot-names)) (flet ((lose (initarg value string) - (error "when initializing the method ~S:~%~ - The ~S initialization argument was: ~S.~%~ - which ~A." - method initarg value string))) + (error "when initializing the method ~S:~%~ + The ~S initialization argument was: ~S.~%~ + which ~A." + method initarg value string))) (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) - (check-lambda-list (legal-lambda-list-p method lambda-list)) - (check-specializers (legal-specializers-p method specializers)) - (check-fun (legal-method-function-p method - (or function - fast-function))) - (check-documentation (legal-documentation-p method documentation))) + (check-lambda-list (legal-lambda-list-p method lambda-list)) + (check-specializers (legal-specializers-p method specializers)) + (check-fun (legal-method-function-p method + (or function + fast-function))) + (check-documentation (legal-documentation-p method documentation))) (unless (eq check-qualifiers t) - (lose :qualifiers qualifiers check-qualifiers)) + (lose :qualifiers qualifiers check-qualifiers)) (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) + (lose :lambda-list lambda-list check-lambda-list)) (unless (eq check-specializers t) - (lose :specializers specializers check-specializers)) + (lose :specializers specializers check-specializers)) (unless (eq check-fun t) - (lose :function function check-fun)) + (lose :function function check-fun)) (unless (eq check-documentation t) - (lose :documentation documentation check-documentation))))) + (lose :documentation documentation check-documentation))))) (defmethod shared-initialize :before ((method standard-accessor-method) - slot-names - &key slot-name slot-definition) + slot-names + &key slot-name slot-definition) (declare (ignore slot-names)) (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and ;; ILLEGALP, and the convention redone to be less twisty (unless (eq legalp t) - (error "The value of the :SLOT-NAME initarg ~A." legalp))))) + (error "The value of the :SLOT-NAME initarg ~A." legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names - &rest initargs - &key qualifiers method-spec plist) + &rest initargs + &key qualifiers method-spec plist) (declare (ignore slot-names method-spec plist)) (initialize-method-function initargs nil method) (setf (plist-value method 'qualifiers) qualifiers) #+ignore (setf (slot-value method 'closure-generator) - (method-function-closure-generator (slot-value method 'function)))) + (method-function-closure-generator (slot-value method 'function)))) (defmethod shared-initialize :after ((method standard-accessor-method) - slot-names - &key) + slot-names + &key) (declare (ignore slot-names)) (with-slots (slot-name slot-definition) method (unless slot-definition (let ((class (accessor-method-class method))) - (when (slot-class-p class) - (setq slot-definition (find slot-name (class-direct-slots class) - :key #'slot-definition-name))))) + (when (slot-class-p class) + (setq slot-definition (find slot-name (class-direct-slots class) + :key #'slot-definition-name))))) (when (and slot-definition (null slot-name)) (setq slot-name (slot-definition-name slot-definition))))) @@ -188,74 +188,74 @@ (find-class 'standard-generic-function)) (defmethod shared-initialize :before - ((generic-function standard-generic-function) - slot-names - &key (name nil namep) - (lambda-list () lambda-list-p) - argument-precedence-order - declarations - documentation - (method-class nil method-class-supplied-p) - (method-combination nil method-combination-supplied-p)) + ((generic-function standard-generic-function) + slot-names + &key (name nil namep) + (lambda-list () lambda-list-p) + argument-precedence-order + declarations + documentation + (method-class nil method-class-supplied-p) + (method-combination nil method-combination-supplied-p)) (declare (ignore slot-names - declarations argument-precedence-order documentation - lambda-list lambda-list-p)) + declarations argument-precedence-order documentation + lambda-list lambda-list-p)) (when namep (set-fun-name generic-function name)) (flet ((initarg-error (initarg value string) - (error "when initializing the generic function ~S:~%~ - The ~S initialization argument was: ~A.~%~ - It must be ~A." - generic-function initarg value string))) + (error "when initializing the generic function ~S:~%~ + The ~S initialization argument was: ~A.~%~ + It must be ~A." + generic-function initarg value string))) (cond (method-class-supplied-p - (when (symbolp method-class) - (setq method-class (find-class method-class))) - (unless (and (classp method-class) - (*subtypep (class-eq-specializer method-class) - *the-class-method*)) - (initarg-error :method-class - method-class - "a subclass of the class METHOD")) - (setf (slot-value generic-function 'method-class) method-class)) - ((slot-boundp generic-function 'method-class)) - (t - (initarg-error :method-class - "not supplied" - "a subclass of the class METHOD"))) + (when (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (and (classp method-class) + (*subtypep (class-eq-specializer method-class) + *the-class-method*)) + (initarg-error :method-class + method-class + "a subclass of the class METHOD")) + (setf (slot-value generic-function 'method-class) method-class)) + ((slot-boundp generic-function 'method-class)) + (t + (initarg-error :method-class + "not supplied" + "a subclass of the class METHOD"))) (cond (method-combination-supplied-p - (unless (method-combination-p method-combination) - (initarg-error :method-combination - method-combination - "a method combination object"))) - ((slot-boundp generic-function 'method-combination)) - (t - (initarg-error :method-combination - "not supplied" - "a method combination object"))))) + (unless (method-combination-p method-combination) + (initarg-error :method-combination + method-combination + "a method combination object"))) + ((slot-boundp generic-function 'method-combination)) + (t + (initarg-error :method-combination + "not supplied" + "a method combination object"))))) #|| (defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs - &key name - lambda-list - argument-precedence-order - declarations - documentation - method-class - method-combination) + &rest initargs + &key name + lambda-list + argument-precedence-order + declarations + documentation + method-class + method-combination) (declare (ignore documentation declarations argument-precedence-order - lambda-list name method-class method-combination)) + lambda-list name method-class method-combination)) (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) initargs) - (push ,name initargs)))) + `(unless ,check + (push (slot-value generic-function ,slot-name) initargs) + (push ,name initargs)))) ; (add-initarg name :name 'name) ; (add-initarg lambda-list :lambda-list 'lambda-list) ; (add-initarg argument-precedence-order -; :argument-precedence-order -; 'argument-precedence-order) +; :argument-precedence-order +; 'argument-precedence-order) ; (add-initarg declarations :declarations 'declarations) ; (add-initarg documentation :documentation 'documentation) ; (add-initarg method-class :method-class 'method-class) @@ -265,26 +265,26 @@ ;;; These two are scheduled for demolition. (defun real-add-named-method (generic-function-name - qualifiers - specializers - lambda-list - &rest other-initargs) + qualifiers + specializers + lambda-list + &rest other-initargs) (unless (and (fboundp generic-function-name) - (typep (fdefinition generic-function-name) 'generic-function)) + (typep (fdefinition generic-function-name) 'generic-function)) (style-warn "implicitly creating new generic function ~S" - generic-function-name)) + generic-function-name)) ;; XXX What about changing the class of the generic function if ;; there is one? Whose job is that, anyway? Do we need something ;; kind of like CLASS-FOR-REDEFINITION? (let* ((generic-function - (ensure-generic-function generic-function-name)) - (specs (parse-specializers specializers)) - (proto (method-prototype-for-gf generic-function-name)) - (new (apply #'make-instance (class-of proto) - :qualifiers qualifiers - :specializers specs - :lambda-list lambda-list - other-initargs))) + (ensure-generic-function generic-function-name)) + (specs (parse-specializers specializers)) + (proto (method-prototype-for-gf generic-function-name)) + (new (apply #'make-instance (class-of proto) + :qualifiers qualifiers + :specializers specs + :lambda-list lambda-list + other-initargs))) (add-method generic-function new) new)) @@ -294,52 +294,52 @@ (:default-initargs :references (list '(:ansi-cl :function find-method)))) (defun real-get-method (generic-function qualifiers specializers - &optional (errorp t) - always-check-specializers) + &optional (errorp t) + always-check-specializers) (let ((lspec (length specializers)) - (methods (generic-function-methods generic-function))) + (methods (generic-function-methods generic-function))) (when (or methods always-check-specializers) (let ((nreq (length (arg-info-metatypes (gf-arg-info - generic-function))))) - ;; Since we internally bypass FIND-METHOD by using GET-METHOD - ;; instead we need to to this here or users may get hit by a - ;; failed AVER instead of a sensible error message. - (when (/= lspec nreq) - (error - 'find-method-length-mismatch - :format-control - "~@" - :format-arguments (list generic-function nreq specializers))))) - (let ((hit - (dolist (method methods) - (let ((mspecializers (method-specializers method))) - (aver (= lspec (length mspecializers))) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers - (method-specializers method))) - (return method)))))) + :format-arguments (list generic-function nreq specializers))))) + (let ((hit + (dolist (method methods) + (let ((mspecializers (method-specializers method))) + (aver (= lspec (length mspecializers))) + (when (and (equal qualifiers (method-qualifiers method)) + (every #'same-specializer-p specializers + (method-specializers method))) + (return method)))))) (cond (hit hit) - ((null errorp) nil) - (t - (error "~@" - generic-function qualifiers specializers)))))) + generic-function qualifiers specializers)))))) (defmethod find-method ((generic-function standard-generic-function) - qualifiers specializers &optional (errorp t)) + qualifiers specializers &optional (errorp t)) ;; ANSI about FIND-METHOD: "The specializers argument contains the ;; parameter specializers for the method. It must correspond in ;; length to the number of required arguments of the generic ;; function, or an error is signaled." ;; ;; This error checking is done by REAL-GET-METHOD. - (real-get-method generic-function - qualifiers - (parse-specializers specializers) - errorp - t)) + (real-get-method generic-function + qualifiers + (parse-specializers specializers) + errorp + t)) ;;; Compute various information about a generic-function's arglist by looking ;;; at the argument lists of the methods. The hair for trying not to use @@ -356,34 +356,34 @@ ;;; specializes (e.g. for a classical generic-function this is the ;;; list: (1)). (defmethod compute-discriminating-function-arglist-info - ((generic-function standard-generic-function)) + ((generic-function standard-generic-function)) ;;(declare (values number-of-required-arguments &rest-argument-p - ;; specialized-argument-postions)) + ;; specialized-argument-postions)) (let ((number-required nil) - (restp nil) - (specialized-positions ()) - (methods (generic-function-methods generic-function))) + (restp nil) + (specialized-positions ()) + (methods (generic-function-methods generic-function))) (dolist (method methods) (multiple-value-setq (number-required restp specialized-positions) - (compute-discriminating-function-arglist-info-internal - generic-function method number-required restp specialized-positions))) + (compute-discriminating-function-arglist-info-internal + generic-function method number-required restp specialized-positions))) (values number-required restp (sort specialized-positions #'<)))) (defun compute-discriminating-function-arglist-info-internal (generic-function method number-of-requireds restp - specialized-argument-positions) + specialized-argument-positions) (declare (ignore generic-function) - (type (or null fixnum) number-of-requireds)) + (type (or null fixnum) number-of-requireds)) (let ((requireds 0)) (declare (fixnum requireds)) ;; Go through this methods arguments seeing how many are required, ;; and whether there is an &rest argument. (dolist (arg (method-lambda-list method)) (cond ((eq arg '&aux) (return)) - ((memq arg '(&optional &rest &key)) - (return (setq restp t))) - ((memq arg lambda-list-keywords)) - (t (incf requireds)))) + ((memq arg '(&optional &rest &key)) + (return (setq restp t))) + ((memq arg lambda-list-keywords)) + (t (incf requireds)))) ;; Now go through this method's type specifiers to see which ;; argument positions are type specified. Treat T specially ;; in the usual sort of way. For efficiency don't bother to @@ -399,29 +399,29 @@ ;; num-of-requireds is NIL it means this is the first method ;; and we depend on that. (values (min (or number-of-requireds requireds) requireds) - (or restp - (and number-of-requireds (/= number-of-requireds requireds))) - specialized-argument-positions))) + (or restp + (and number-of-requireds (/= number-of-requireds requireds))) + specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (let ((args nil)) (dotimes (i number-required-arguments) (push (format-symbol *package* ;; ! is this right? - "Discriminating Function Arg ~D" - i) + "Discriminating Function Arg ~D" + i) args)) (nreverse args)) - (when restp - `(&rest ,(format-symbol *package* - "Discriminating Function &rest Arg"))))) + (when restp + `(&rest ,(format-symbol *package* + "Discriminating Function &rest Arg"))))) (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) (aver (eq *boot-state* 'complete)) (loop with arg-info = (gf-arg-info gf) - with lambda-list = (arg-info-lambda-list arg-info) - for argument-position in (arg-info-precedence arg-info) - collect (nth argument-position lambda-list))) + with lambda-list = (arg-info-lambda-list arg-info) + for argument-position in (arg-info-precedence arg-info) + collect (nth argument-position lambda-list))) (defmethod generic-function-lambda-list ((gf generic-function)) (gf-lambda-list gf)) @@ -430,14 +430,14 @@ (gf-info-fast-mf-p (slot-value gf 'arg-info))) (defmethod initialize-instance :after ((gf standard-generic-function) - &key (lambda-list nil lambda-list-p) - argument-precedence-order) + &key (lambda-list nil lambda-list-p) + argument-precedence-order) (with-slots (arg-info) gf (if lambda-list-p - (set-arg-info gf - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info gf)) + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info gf)) (when (arg-info-valid-p arg-info) (update-dfun gf)))) @@ -448,135 +448,135 @@ (prog1 (call-next-method) ;; KLUDGE: EQ is too strong a test. (unless (eq old-mc (generic-function-method-combination gf)) - (flush-effective-method-cache gf)) + (flush-effective-method-cache gf)) (cond - ((and lambda-list-p apo-p) - (set-arg-info gf - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order)) - (lambda-list-p (set-arg-info gf :lambda-list lambda-list)) - (t (set-arg-info gf))) + ((and lambda-list-p apo-p) + (set-arg-info gf + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order)) + (lambda-list-p (set-arg-info gf :lambda-list lambda-list)) + (t (set-arg-info gf))) (when (and (arg-info-valid-p (gf-arg-info gf)) - (not (null args)) - (or lambda-list-p (cddr args))) - (update-dfun gf))))) + (not (null args)) + (or lambda-list-p (cddr args))) + (update-dfun gf))))) (declaim (special *lazy-dfun-compute-p*)) (defun set-methods (gf methods) (setf (generic-function-methods gf) nil) (loop (when (null methods) (return gf)) - (real-add-method gf (pop methods) methods))) + (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) (when (method-generic-function method) (error "~@" - method (method-generic-function method))) + function ~S; it can't be added to another generic ~ + function until it is removed from the first one.~@:>" + method (method-generic-function method))) (flet ((similar-lambda-lists-p (method-a method-b) - (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) - (analyze-lambda-list (method-lambda-list method-a)) - (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) - (analyze-lambda-list (method-lambda-list method-b)) - (and (= a-nreq b-nreq) - (= a-nopt b-nopt) - (eq (or a-keyp a-restp) - (or b-keyp b-restp))))))) + (multiple-value-bind (a-nreq a-nopt a-keyp a-restp) + (analyze-lambda-list (method-lambda-list method-a)) + (multiple-value-bind (b-nreq b-nopt b-keyp b-restp) + (analyze-lambda-list (method-lambda-list method-b)) + (and (= a-nreq b-nreq) + (= a-nopt b-nopt) + (eq (or a-keyp a-restp) + (or b-keyp b-restp))))))) (let* ((name (generic-function-name generic-function)) - (qualifiers (method-qualifiers method)) - (specializers (method-specializers method)) - (existing (get-method generic-function - qualifiers - specializers - nil))) - - ;; If there is already a method like this one then we must get - ;; rid of it before proceeding. Note that we call the generic - ;; function REMOVE-METHOD to remove it rather than doing it in - ;; some internal way. - (when (and existing (similar-lambda-lists-p existing method)) - (remove-method generic-function existing)) - - (setf (method-generic-function method) generic-function) - (pushnew method (generic-function-methods generic-function)) - (dolist (specializer specializers) - (add-direct-method specializer method)) - - ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for - ;; detecting attempts to add methods with incongruent lambda - ;; lists. However, according to Gerd Moellmann on cmucl-imp, - ;; it also depends on the new method already having been added - ;; to the generic function. Therefore, we need to remove it - ;; again on error: - (let ((remove-again-p t)) - (unwind-protect - (progn - (set-arg-info generic-function :new-method method) - (setq remove-again-p nil)) - (when remove-again-p - (remove-method generic-function method)))) - - ;; KLUDGE II: ANSI saith that it is not an error to add a - ;; method with invalid qualifiers to a generic function of the - ;; wrong kind; it's only an error at generic function - ;; invocation time; I dunno what the rationale was, and it - ;; sucks. Nevertheless, it's probably a programmer error, so - ;; let's warn anyway. -- CSR, 2003-08-20 - (let ((mc (generic-function-method-combination generic-functioN))) - (cond - ((eq mc *standard-method-combination*) - (when (and qualifiers - (or (cdr qualifiers) - (not (memq (car qualifiers) - '(:around :before :after))))) - (warn "~@" - method qualifiers))) - ((short-method-combination-p mc) - (let ((mc-name (method-combination-type mc))) - (when (or (null qualifiers) - (cdr qualifiers) - (and (neq (car qualifiers) :around) - (neq (car qualifiers) mc-name))) - (warn "~@" - mc-name method qualifiers)))))) - - (unless skip-dfun-update-p - (update-ctors 'add-method - :generic-function generic-function - :method method) - (update-dfun generic-function)) - generic-function))) + mc-name method qualifiers)))))) + + (unless skip-dfun-update-p + (update-ctors 'add-method + :generic-function generic-function + :method method) + (update-dfun generic-function)) + generic-function))) (defun real-remove-method (generic-function method) (when (eq generic-function (method-generic-function method)) (let* ((name (generic-function-name generic-function)) - (specializers (method-specializers method)) - (methods (generic-function-methods generic-function)) - (new-methods (remove method methods))) + (specializers (method-specializers method)) + (methods (generic-function-methods generic-function)) + (new-methods (remove method methods))) (setf (method-generic-function method) nil) (setf (generic-function-methods generic-function) new-methods) (dolist (specializer (method-specializers method)) - (remove-direct-method specializer method)) + (remove-direct-method specializer method)) (set-arg-info generic-function) (update-ctors 'remove-method - :generic-function generic-function - :method method) + :generic-function generic-function + :method method) (update-dfun generic-function))) generic-function) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-args generic-function arguments 'eql)))) + generic-function + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types - generic-function - (types-from-args generic-function arguments 'eql)))) + generic-function + (types-from-args generic-function arguments 'eql)))) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) @@ -586,22 +586,22 @@ (defun proclaim-incompatible-superclasses (classes) (setq classes (mapcar (lambda (class) - (if (symbolp class) - (find-class class) - class)) - classes)) + (if (symbolp class) + (find-class class) + class)) + classes)) (dolist (class classes) (dolist (other-class classes) (unless (eq class other-class) - (pushnew other-class (class-incompatible-superclass-list class)))))) + (pushnew other-class (class-incompatible-superclass-list class)))))) (defun superclasses-compatible-p (class1 class2) (let ((cpl1 (cpl-or-nil class1)) - (cpl2 (cpl-or-nil class2))) + (cpl2 (cpl-or-nil class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) - (when (memq ic cpl2) - (return-from superclasses-compatible-p nil)))))) + (when (memq ic cpl2) + (return-from superclasses-compatible-p nil)))))) (mapc #'proclaim-incompatible-superclasses @@ -612,15 +612,15 @@ (class eql-specializer class-eq-specializer method method-combination generic-function slot-definition) ;; metaclass built-in-class - (number sequence character ; direct subclasses of t, but not array - standard-object structure-object) ; or symbol + (number sequence character ; direct subclasses of t, but not array + standard-object structure-object) ; or symbol (number array character symbol ; direct subclasses of t, but not - standard-object structure-object) ; sequence - (complex float rational) ; direct subclasses of number - (integer ratio) ; direct subclasses of rational - (list vector) ; direct subclasses of sequence - (cons null) ; direct subclasses of list - (string bit-vector) ; direct subclasses of vector + standard-object structure-object) ; sequence + (complex float rational) ; direct subclasses of number + (integer ratio) ; direct subclasses of rational + (list vector) ; direct subclasses of sequence + (cons null) ; direct subclasses of list + (string bit-vector) ; direct subclasses of vector )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) @@ -633,11 +633,11 @@ specializer) (defmethod same-specializer-p ((specl1 class-eq-specializer) - (specl2 class-eq-specializer)) + (specl2 class-eq-specializer)) (eq (specializer-class specl1) (specializer-class specl2))) (defmethod same-specializer-p ((specl1 eql-specializer) - (specl2 eql-specializer)) + (specl2 eql-specializer)) (eq (specializer-object specl1) (specializer-object specl2))) (defmethod specializer-class ((specializer eql-specializer)) @@ -646,17 +646,17 @@ (defvar *in-gf-arg-info-p* nil) (setf (gdefinition 'arg-info-reader) (let ((mf (initialize-method-function - (make-internal-reader-method-function - 'standard-generic-function 'arg-info) - t))) - (lambda (&rest args) (funcall mf args nil)))) + (make-internal-reader-method-function + 'standard-generic-function 'arg-info) + t))) + (lambda (&rest args) (funcall mf args nil)))) (defun error-need-at-least-n-args (function n) (error 'simple-program-error - :format-control "~@" - :format-arguments (list function n))) + :format-arguments (list function n))) (defun types-from-args (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) @@ -664,72 +664,72 @@ (declare (ignore applyp metatypes nkeys)) (let ((types-rev nil)) (dotimes-fixnum (i nreq) - i - (unless arguments - (error-need-at-least-n-args (generic-function-name generic-function) - nreq)) - (let ((arg (pop arguments))) - (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) + i + (unless arguments + (error-need-at-least-n-args (generic-function-name generic-function) + nreq)) + (let ((arg (pop arguments))) + (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) (unless (eq t (car mt-tail)) - (let ((c-w (class-wrapper class))) - (unless c-w (return-from get-wrappers-from-classes nil)) - (if (eql nkeys 1) - (setq w c-w) - (setf (car w-tail) c-w - w-tail (cdr w-tail))))) + (let ((c-w (class-wrapper class))) + (unless c-w (return-from get-wrappers-from-classes nil)) + (if (eql nkeys 1) + (setq w c-w) + (setf (car w-tail) c-w + w-tail (cdr w-tail))))) (setq mt-tail (cdr mt-tail))) w)) (defun sdfun-for-caching (gf classes) (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) - (compute-applicable-methods-using-types gf types) + (compute-applicable-methods-using-types gf types) (let ((generator (get-secondary-dispatch-function1 - gf methods types nil t all-applicable-and-sorted-p))) - (make-callable gf methods generator - nil (mapcar #'class-wrapper classes)))))) + gf methods types nil t all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (mapcar #'class-wrapper classes)))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types - gf (mapcar #'class-eq-type classes)))) + gf (mapcar #'class-eq-type classes)))) (method-function-get (or (method-fast-function (car methods)) - (method-function (car methods))) - :constant-value))) + (method-function (car methods))) + :constant-value))) (defun default-secondary-dispatch-function (generic-function) (lambda (&rest args) (let ((methods (compute-applicable-methods generic-function args))) (if methods - (let ((emf (get-effective-method-function generic-function - methods))) - (invoke-emf emf args)) - (apply #'no-applicable-method generic-function args))))) + (let ((emf (get-effective-method-function generic-function + methods))) + (invoke-emf emf args)) + (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) - (when (atom y) (return nil)) - (unless (eq (car x) (car y)) (return nil)) - (setq x (cdr x) - y (cdr y)))) + (when (atom y) (return nil)) + (unless (eq (car x) (car y)) (return nil)) + (setq x (cdr x) + y (cdr y)))) (defvar *std-cam-methods* nil) (defun compute-applicable-methods-emf (generic-function) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) - (cam-methods (compute-applicable-methods-using-types - cam (list `(eql ,generic-function) t)))) - (values (get-effective-method-function cam cam-methods) - (list-eq cam-methods - (or *std-cam-methods* - (setq *std-cam-methods* - (compute-applicable-methods-using-types - cam (list `(eql ,cam) t))))))) + (cam-methods (compute-applicable-methods-using-types + cam (list `(eql ,generic-function) t)))) + (values (get-effective-method-function cam cam-methods) + (list-eq cam-methods + (or *std-cam-methods* + (setq *std-cam-methods* + (compute-applicable-methods-using-types + cam (list `(eql ,cam) t))))))) (values #'compute-applicable-methods-function t))) (defun compute-applicable-methods-emf-std-p (gf) @@ -740,25 +740,25 @@ (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* - (every (lambda (old-method) - (member old-method methods)) - *old-c-a-m-gf-methods*)) - (let ((gfs-to-do nil) - (gf-classes-to-do nil)) - (dolist (method methods) - (unless (member method *old-c-a-m-gf-methods*) - (let ((specl (car (method-specializers method)))) - (if (eql-specializer-p specl) - (pushnew (specializer-object specl) gfs-to-do) - (pushnew (specializer-class specl) gf-classes-to-do))))) - (map-all-generic-functions - (lambda (gf) - (when (or (member gf gfs-to-do) - (dolist (class gf-classes-to-do nil) - (member class - (class-precedence-list (class-of gf))))) - (update-c-a-m-gf-info gf))))) - (map-all-generic-functions #'update-c-a-m-gf-info)) + (every (lambda (old-method) + (member old-method methods)) + *old-c-a-m-gf-methods*)) + (let ((gfs-to-do nil) + (gf-classes-to-do nil)) + (dolist (method methods) + (unless (member method *old-c-a-m-gf-methods*) + (let ((specl (car (method-specializers method)))) + (if (eql-specializer-p specl) + (pushnew (specializer-object specl) gfs-to-do) + (pushnew (specializer-class specl) gf-classes-to-do))))) + (map-all-generic-functions + (lambda (gf) + (when (or (member gf gfs-to-do) + (dolist (class gf-classes-to-do nil) + (member class + (class-precedence-list (class-of gf))))) + (update-c-a-m-gf-info gf))))) + (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) (defun update-gf-info (gf) @@ -768,33 +768,33 @@ (defun update-c-a-m-gf-info (gf) (unless (early-gf-p gf) (multiple-value-bind (c-a-m-emf std-p) - (compute-applicable-methods-emf gf) + (compute-applicable-methods-emf gf) (let ((arg-info (gf-arg-info gf))) - (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) (defun update-gf-simple-accessor-type (gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-simple-accessor-type arg-info) - (let* ((methods (generic-function-methods gf)) - (class (and methods (class-of (car methods)))) - (type (and class - (cond ((eq class - *the-class-standard-reader-method*) - 'reader) - ((eq class - *the-class-standard-writer-method*) - 'writer) - ((eq class - *the-class-standard-boundp-method*) - 'boundp))))) - (when (and (gf-info-c-a-m-emf-std-p arg-info) - type - (dolist (method (cdr methods) t) - (unless (eq class (class-of method)) (return nil))) - (eq (generic-function-method-combination gf) - *standard-method-combination*)) - type))))) + (let* ((methods (generic-function-methods gf)) + (class (and methods (class-of (car methods)))) + (type (and class + (cond ((eq class + *the-class-standard-reader-method*) + 'reader) + ((eq class + *the-class-standard-writer-method*) + 'writer) + ((eq class + *the-class-standard-boundp-method*) + 'boundp))))) + (when (and (gf-info-c-a-m-emf-std-p arg-info) + type + (dolist (method (cdr methods) t) + (unless (eq class (class-of method)) (return nil))) + (eq (generic-function-method-combination gf) + *standard-method-combination*)) + type))))) ;;; CMUCL (Gerd's PCL, 2002-04-25) comment: @@ -814,33 +814,33 @@ ;;; 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))) - (types (if (eq type 'writer) `(t ,@types1) types1)) - (methods (compute-applicable-methods-using-types gf types)) - (std-p (null (cdr methods)))) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types)) + (std-p (null (cdr methods)))) (values (if std-p - (get-optimized-std-accessor-method-function class slotd type) - (let* ((optimized-std-fun - (get-optimized-std-slot-value-using-class-method-function - class slotd type)) - (method-alist - `((,(car (or (member std-method methods) - (member str-method methods) - (bug "error in ~S" - 'get-accessor-method-function))) - ,optimized-std-fun))) - (wrappers - (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))) + (get-optimized-std-accessor-method-function class slotd type) + (let* ((optimized-std-fun + (get-optimized-std-slot-value-using-class-method-function + class slotd type)) + (method-alist + `((,(car (or (member std-method methods) + (member str-method methods) + (bug "error in ~S" + 'get-accessor-method-function))) + ,optimized-std-fun))) + (wrappers + (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) @@ -849,12 +849,12 @@ (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))))) + (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))))) + (update-class *new-class*) + (map-all-classes #'update-class 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) @@ -906,107 +906,107 @@ (dolist (method (generic-function-methods gf)) (let ((specls (method-specializers method))) (when (and (or (not (eq type 'writer)) - (eq (pop specls) *the-class-t*)) - (every #'classp specls)) - (cond ((and (eq (class-name (car specls)) 'std-class) - (eq (class-name (cadr specls)) 'std-object) - (eq (class-name (caddr specls)) - 'standard-effective-slot-definition)) - (set-standard-svuc-method type method)) - ((and (eq (class-name (car specls)) 'condition-class) - (eq (class-name (cadr specls)) 'condition) - (eq (class-name (caddr specls)) - 'condition-effective-slot-definition)) - (set-condition-svuc-method type method)) - ((and (eq (class-name (car specls)) 'structure-class) - (eq (class-name (cadr specls)) 'structure-object) - (eq (class-name (caddr specls)) - 'structure-effective-slot-definition)) - (set-structure-svuc-method type method))))))) + (eq (pop specls) *the-class-t*)) + (every #'classp specls)) + (cond ((and (eq (class-name (car specls)) 'std-class) + (eq (class-name (cadr specls)) 'std-object) + (eq (class-name (caddr specls)) + 'standard-effective-slot-definition)) + (set-standard-svuc-method type method)) + ((and (eq (class-name (car specls)) 'condition-class) + (eq (class-name (cadr specls)) 'condition) + (eq (class-name (caddr specls)) + 'condition-effective-slot-definition)) + (set-condition-svuc-method type method)) + ((and (eq (class-name (car specls)) 'structure-class) + (eq (class-name (cadr specls)) 'structure-object) + (eq (class-name (caddr specls)) + 'structure-effective-slot-definition)) + (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) (cons (specializer-class spec) - (and (classp spec) - precompute-p - (not (or (eq spec *the-class-t*) - (eq spec *the-class-slot-object*) - (eq spec *the-class-std-object*) - (eq spec *the-class-standard-object*) - (eq spec *the-class-structure-object*))) - (let ((sc (class-direct-subclasses spec))) - (when sc - (mapcan (lambda (class) - (mec-all-classes-internal class precompute-p)) - sc)))))) + (and (classp spec) + precompute-p + (not (or (eq spec *the-class-t*) + (eq spec *the-class-slot-object*) + (eq spec *the-class-std-object*) + (eq spec *the-class-standard-object*) + (eq spec *the-class-structure-object*))) + (let ((sc (class-direct-subclasses spec))) + (when sc + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) + sc)))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) (if (null (cdr classes)) - classes - (let* ((a-classes (cons nil classes)) - (tail classes)) - (loop (when (null (cdr tail)) - (return (cdr a-classes))) - (let ((class (cadr tail)) - (ttail (cddr tail))) - (if (dolist (c ttail nil) - (when (eq class c) (return t))) - (setf (cdr tail) (cddr tail)) - (setf tail (cdr tail))))))))) + classes + (let* ((a-classes (cons nil classes)) + (tail classes)) + (loop (when (null (cdr tail)) + (return (cdr a-classes))) + (let ((class (cadr tail)) + (ttail (cddr tail))) + (if (dolist (c ttail nil) + (when (eq class c) (return t))) + (setf (cdr tail) (cddr tail)) + (setf tail (cdr tail))))))))) (defun mec-all-class-lists (spec-list precompute-p) (if (null spec-list) (list nil) (let* ((car-all-classes (mec-all-classes (car spec-list) - precompute-p)) - (all-class-lists (mec-all-class-lists (cdr spec-list) - precompute-p))) - (mapcan (lambda (list) - (mapcar (lambda (c) (cons c list)) car-all-classes)) - all-class-lists)))) + precompute-p)) + (all-class-lists (mec-all-class-lists (cdr spec-list) + precompute-p))) + (mapcan (lambda (list) + (mapcar (lambda (c) (cons c list)) car-all-classes)) + all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info)) - (metatypes (arg-info-metatypes arg-info)) - (wrappers (unless (eq nkeys 1) (make-list nkeys))) - (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) - (default '(default))) + (nkeys (arg-info-nkeys arg-info)) + (metatypes (arg-info-metatypes arg-info)) + (wrappers (unless (eq nkeys 1) (make-list nkeys))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) + (default '(default))) (flet ((add-class-list (classes) - (when (or (null new-class) (memq new-class classes)) - (let ((wrappers (get-wrappers-from-classes - nkeys wrappers classes metatypes))) - (when (and wrappers - (eq default (probe-cache cache wrappers default))) - (let ((value (cond ((eq valuep t) - (sdfun-for-caching generic-function - classes)) - ((eq valuep :constant-value) - (value-for-caching generic-function - classes))))) - (setq cache (fill-cache cache wrappers value)))))))) + (when (or (null new-class) (memq new-class classes)) + (let ((wrappers (get-wrappers-from-classes + nkeys wrappers classes metatypes))) + (when (and wrappers + (eq default (probe-cache cache wrappers default))) + (let ((value (cond ((eq valuep t) + (sdfun-for-caching generic-function + classes)) + ((eq valuep :constant-value) + (value-for-caching generic-function + classes))))) + (setq cache (fill-cache cache wrappers value)))))))) (if classes-list - (mapc #'add-class-list classes-list) - (dolist (method (generic-function-methods generic-function)) - (mapc #'add-class-list - (mec-all-class-lists (method-specializers method) - precompute-p)))) + (mapc #'add-class-list classes-list) + (dolist (method (generic-function-methods generic-function)) + (mapc #'add-class-list + (mec-all-class-lists (method-specializers method) + precompute-p)))) cache))) (defmacro class-test (arg class) (cond ((eq class *the-class-t*) - t) - ((eq class *the-class-slot-object*) - `(not (typep (classoid-of ,arg) - 'built-in-classoid))) - ((eq class *the-class-std-object*) - `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) - ((eq class *the-class-standard-object*) - `(std-instance-p ,arg)) - ((eq class *the-class-funcallable-standard-object*) - `(fsc-instance-p ,arg)) - (t - `(typep ,arg ',(class-name class))))) + t) + ((eq class *the-class-slot-object*) + `(not (typep (classoid-of ,arg) + 'built-in-classoid))) + ((eq class *the-class-std-object*) + `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + ((eq class *the-class-standard-object*) + `(std-instance-p ,arg)) + ((eq class *the-class-funcallable-standard-object*) + `(fsc-instance-p ,arg)) + (t + `(typep ,arg ',(class-name class))))) (defmacro class-eq-test (arg class) `(eq (class-of ,arg) ',class)) @@ -1017,201 +1017,201 @@ (defun dnet-methods-p (form) (and (consp form) (or (eq (car form) 'methods) - (eq (car form) 'unordered-methods)))) + (eq (car form) 'unordered-methods)))) ;;; This is CASE, but without gensyms. (defmacro scase (arg &rest clauses) `(let ((.case-arg. ,arg)) (cond ,@(mapcar (lambda (clause) - (list* (cond ((null (car clause)) - nil) - ((consp (car clause)) - (if (null (cdar clause)) - `(eql .case-arg. - ',(caar clause)) - `(member .case-arg. - ',(car clause)))) - ((member (car clause) '(t otherwise)) - `t) - (t - `(eql .case-arg. ',(car clause)))) - nil - (cdr clause))) - clauses)))) + (list* (cond ((null (car clause)) + nil) + ((consp (car clause)) + (if (null (cdar clause)) + `(eql .case-arg. + ',(caar clause)) + `(member .case-arg. + ',(car clause)))) + ((member (car clause) '(t otherwise)) + `t) + (t + `(eql .case-arg. ',(car clause)))) + nil + (cdr clause))) + clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) (defun generate-discrimination-net (generic-function methods types sorted-p) (let* ((arg-info (gf-arg-info generic-function)) - (precedence (arg-info-precedence arg-info))) + (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types (lambda (methods known-types) (if (or sorted-p - (block one-order-p - (let ((sorted-methods nil)) - (map-all-orders - (copy-list methods) precedence - (lambda (methods) - (when sorted-methods (return-from one-order-p nil)) - (setq sorted-methods methods))) - (setq methods sorted-methods)) - t)) - `(methods ,methods ,known-types) - `(unordered-methods ,methods ,known-types))) + (block one-order-p + (let ((sorted-methods nil)) + (map-all-orders + (copy-list methods) precedence + (lambda (methods) + (when sorted-methods (return-from one-order-p nil)) + (setq sorted-methods methods))) + (setq methods sorted-methods)) + t)) + `(methods ,methods ,known-types) + `(unordered-methods ,methods ,known-types))) (lambda (position type true-value false-value) (let ((arg (dfun-arg-symbol position))) - (if (eq (car type) 'eql) - (let* ((false-case-p (and (consp false-value) - (or (eq (car false-value) 'scase) - (eq (car false-value) 'mcase)) - (eq arg (cadr false-value)))) - (false-clauses (if false-case-p - (cddr false-value) - `((t ,false-value)))) - (case-sym (if (and (dnet-methods-p true-value) - (if false-case-p - (eq (car false-value) 'mcase) - (dnet-methods-p false-value))) - 'mcase - 'scase)) - (type-sym `(,(cadr type)))) - `(,case-sym ,arg - (,type-sym ,true-value) - ,@false-clauses)) - `(if ,(let ((arg (dfun-arg-symbol position))) - (case (car type) - (class `(class-test ,arg ,(cadr type))) - (class-eq `(class-eq-test ,arg ,(cadr type))))) - ,true-value - ,false-value)))) + (if (eq (car type) 'eql) + (let* ((false-case-p (and (consp false-value) + (or (eq (car false-value) 'scase) + (eq (car false-value) 'mcase)) + (eq arg (cadr false-value)))) + (false-clauses (if false-case-p + (cddr false-value) + `((t ,false-value)))) + (case-sym (if (and (dnet-methods-p true-value) + (if false-case-p + (eq (car false-value) 'mcase) + (dnet-methods-p false-value))) + 'mcase + 'scase)) + (type-sym `(,(cadr type)))) + `(,case-sym ,arg + (,type-sym ,true-value) + ,@false-clauses)) + `(if ,(let ((arg (dfun-arg-symbol position))) + (case (car type) + (class `(class-test ,arg ,(cadr type))) + (class-eq `(class-eq-test ,arg ,(cadr type))))) + ,true-value + ,false-value)))) #'identity))) (defun class-from-type (type) (if (or (atom type) (eq (car type) t)) *the-class-t* (case (car type) - (and (dolist (type (cdr type) *the-class-t*) - (when (and (consp type) (not (eq (car type) 'not))) - (return (class-from-type type))))) - (not *the-class-t*) - (eql (class-of (cadr type))) - (class-eq (cadr type)) - (class (cadr type))))) + (and (dolist (type (cdr type) *the-class-t*) + (when (and (consp type) (not (eq (car type) 'not))) + (return (class-from-type type))))) + (not *the-class-t*) + (eql (class-of (cadr type))) + (class-eq (cadr type)) + (class (cadr type))))) (defun precompute-effective-methods (gf caching-p &optional classes-list-p) (let* ((arg-info (gf-arg-info gf)) - (methods (generic-function-methods gf)) - (precedence (arg-info-precedence arg-info)) - (*in-precompute-effective-methods-p* t) - (classes-list nil)) + (methods (generic-function-methods gf)) + (precedence (arg-info-precedence arg-info)) + (*in-precompute-effective-methods-p* t) + (classes-list nil)) (generate-discrimination-net-internal gf methods nil (lambda (methods known-types) (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) - (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p - methods)))) - (map-all-orders - methods precedence - (lambda (methods) - (get-secondary-dispatch-function1 - gf methods known-types - nil caching-p no-eql-specls-p)))))) + (when classes-list-p + (push (mapcar #'class-from-type known-types) classes-list)) + (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p + methods)))) + (map-all-orders + methods precedence + (lambda (methods) + (get-secondary-dispatch-function1 + gf methods known-types + nil caching-p no-eql-specls-p)))))) (lambda (position type true-value false-value) (declare (ignore position type true-value false-value)) nil) (lambda (type) (if (and (consp type) (eq (car type) 'eql)) - `(class-eq ,(class-of (cadr type))) - type))) + `(class-eq ,(class-of (cadr type))) + type))) classes-list)) ;;; We know that known-type implies neither new-type nor `(not ,new-type). (defun augment-type (new-type known-type) (if (or (eq known-type t) - (eq (car new-type) 'eql)) + (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) - (cdr known-type) - (list known-type)))) - (unless (eq (car new-type) 'not) - (setq so-far - (mapcan (lambda (type) - (unless (*subtypep new-type type) - (list type))) - so-far))) - (if (null so-far) - new-type - `(and ,new-type ,@so-far))))) + (cdr known-type) + (list known-type)))) + (unless (eq (car new-type) 'not) + (setq so-far + (mapcan (lambda (type) + (unless (*subtypep new-type type) + (list type))) + so-far))) + (if (null so-far) + new-type + `(and ,new-type ,@so-far))))) (defun generate-discrimination-net-internal (gf methods types methods-function test-fun type-function) (let* ((arg-info (gf-arg-info gf)) - (precedence (arg-info-precedence arg-info)) - (nreq (arg-info-number-required arg-info)) - (metatypes (arg-info-metatypes arg-info))) + (precedence (arg-info-precedence arg-info)) + (nreq (arg-info-number-required arg-info)) + (metatypes (arg-info-metatypes arg-info))) (labels ((do-column (p-tail contenders known-types) - (if p-tail - (let* ((position (car p-tail)) - (known-type (or (nth position types) t))) - (if (eq (nth position metatypes) t) - (do-column (cdr p-tail) contenders - (cons (cons position known-type) - known-types)) - (do-methods p-tail contenders - known-type () known-types))) - (funcall methods-function contenders - (let ((k-t (make-list nreq))) - (dolist (index+type known-types) - (setf (nth (car index+type) k-t) - (cdr index+type))) - k-t)))) - (do-methods (p-tail contenders known-type winners known-types) - ;; CONTENDERS - ;; is a (sorted) list of methods that must be discriminated. - ;; KNOWN-TYPE - ;; is the type of this argument, constructed from tests - ;; already made. - ;; WINNERS - ;; is a (sorted) list of methods that are potentially - ;; applicable after the discrimination has been made. - (if (null contenders) - (do-column (cdr p-tail) - winners - (cons (cons (car p-tail) known-type) - known-types)) - (let* ((position (car p-tail)) - (method (car contenders)) - (specl (nth position (method-specializers method))) - (type (funcall type-function - (type-from-specializer specl)))) - (multiple-value-bind (app-p maybe-app-p) - (specializer-applicable-using-type-p type known-type) - (flet ((determined-to-be (truth-value) - (if truth-value app-p (not maybe-app-p))) - (do-if (truth &optional implied) - (let ((ntype (if truth type `(not ,type)))) - (do-methods p-tail - (cdr contenders) - (if implied - known-type - (augment-type ntype known-type)) - (if truth - (append winners `(,method)) - winners) - known-types)))) - (cond ((determined-to-be nil) (do-if nil t)) - ((determined-to-be t) (do-if t t)) - (t (funcall test-fun position type - (do-if t) (do-if nil)))))))))) + (if p-tail + (let* ((position (car p-tail)) + (known-type (or (nth position types) t))) + (if (eq (nth position metatypes) t) + (do-column (cdr p-tail) contenders + (cons (cons position known-type) + known-types)) + (do-methods p-tail contenders + known-type () known-types))) + (funcall methods-function contenders + (let ((k-t (make-list nreq))) + (dolist (index+type known-types) + (setf (nth (car index+type) k-t) + (cdr index+type))) + k-t)))) + (do-methods (p-tail contenders known-type winners known-types) + ;; CONTENDERS + ;; is a (sorted) list of methods that must be discriminated. + ;; KNOWN-TYPE + ;; is the type of this argument, constructed from tests + ;; already made. + ;; WINNERS + ;; is a (sorted) list of methods that are potentially + ;; applicable after the discrimination has been made. + (if (null contenders) + (do-column (cdr p-tail) + winners + (cons (cons (car p-tail) known-type) + known-types)) + (let* ((position (car p-tail)) + (method (car contenders)) + (specl (nth position (method-specializers method))) + (type (funcall type-function + (type-from-specializer specl)))) + (multiple-value-bind (app-p maybe-app-p) + (specializer-applicable-using-type-p type known-type) + (flet ((determined-to-be (truth-value) + (if truth-value app-p (not maybe-app-p))) + (do-if (truth &optional implied) + (let ((ntype (if truth type `(not ,type)))) + (do-methods p-tail + (cdr contenders) + (if implied + known-type + (augment-type ntype known-type)) + (if truth + (append winners `(,method)) + winners) + known-types)))) + (cond ((determined-to-be nil) (do-if nil t)) + ((determined-to-be t) (do-if t t)) + (t (funcall test-fun position type + (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) (defun compute-secondary-dispatch-function (generic-function net &optional - method-alist wrappers) + method-alist wrappers) (function-funcall (compute-secondary-dispatch-function1 generic-function net) - method-alist wrappers)) + method-alist wrappers)) (defvar *eq-case-table-limit* 15) (defvar *case-table-limit* 10) @@ -1220,19 +1220,19 @@ (unless (eq t (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) - (unless (or (eq (car case) t) - (symbolp (caar case))) - (return nil)))) - (len (1- (length case-list))) - (type (cond ((= len 1) - :simple) - ((<= len - (if eq-p - *eq-case-table-limit* - *case-table-limit*)) - :assoc) - (t - :hash-table)))) + (unless (or (eq (car case) t) + (symbolp (caar case))) + (return nil)))) + (len (1- (length case-list))) + (type (cond ((= len 1) + :simple) + ((<= len + (if eq-p + *eq-case-table-limit* + *case-table-limit*)) + :assoc) + (t + :hash-table)))) (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) @@ -1241,16 +1241,16 @@ (ecase type (:simple `(if (locally - (declare (optimize (inhibit-warnings 3))) - (,(if eq-p 'eq 'eql) ,key (car ,info))) - (cdr ,info) - ,default)) + (declare (optimize (inhibit-warnings 3))) + (,(if eq-p 'eq 'eql) ,key (car ,info))) + (cdr ,info) + ,default)) (:assoc `(dolist (e ,info ,default) - (when (locally - (declare (optimize (inhibit-warnings 3))) - (,(if eq-p 'eq 'eql) (car e) ,key)) - (return (cdr e))))) + (when (locally + (declare (optimize (inhibit-warnings 3))) + (,(if eq-p 'eq 'eql) (car e) ,key)) + (return (cdr e))))) (:hash-table `(gethash ,key ,info ,default)))) @@ -1258,153 +1258,153 @@ (if (atom form) (default-test-converter form) (case (car form) - ((invoke-effective-method-function invoke-fast-method-call) - '.call.) - (methods - '.methods.) - (unordered-methods - '.umethods.) - (mcase - `(mlookup ,(cadr form) - nil - nil - ,@(compute-mcase-parameters (cddr form)))) - (t (default-test-converter form))))) + ((invoke-effective-method-function invoke-fast-method-call) + '.call.) + (methods + '.methods.) + (unordered-methods + '.umethods.) + (mcase + `(mlookup ,(cadr form) + nil + nil + ,@(compute-mcase-parameters (cddr form)))) + (t (default-test-converter form))))) (defun net-code-converter (form) (if (atom form) (default-code-converter form) (case (car form) - ((methods unordered-methods) - (let ((gensym (gensym))) - (values gensym - (list gensym)))) - (mcase - (let ((mp (compute-mcase-parameters (cddr form))) - (gensym (gensym)) (default (gensym))) - (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) - (list gensym default)))) - (t - (default-code-converter form))))) + ((methods unordered-methods) + (let ((gensym (gensym))) + (values gensym + (list gensym)))) + (mcase + (let ((mp (compute-mcase-parameters (cddr form))) + (gensym (gensym)) (default (gensym))) + (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) + (list gensym default)))) + (t + (default-code-converter form))))) (defun net-constant-converter (form generic-function) (or (let ((c (methods-converter form generic-function))) - (when c (list c))) + (when c (list c))) (if (atom form) - (default-constant-converter form) - (case (car form) - (mcase - (let* ((mp (compute-mcase-parameters (cddr form))) - (list (mapcar (lambda (clause) - (let ((key (car clause)) - (meth (cadr clause))) - (cons (if (consp key) (car key) key) - (methods-converter - meth generic-function)))) - (cddr form))) - (default (car (last list)))) - (list (list* :mcase mp (nbutlast list)) - (cdr default)))) - (t - (default-constant-converter form)))))) + (default-constant-converter form) + (case (car form) + (mcase + (let* ((mp (compute-mcase-parameters (cddr form))) + (list (mapcar (lambda (clause) + (let ((key (car clause)) + (meth (cadr clause))) + (cons (if (consp key) (car key) key) + (methods-converter + meth generic-function)))) + (cddr form))) + (default (car (last list)))) + (list (list* :mcase mp (nbutlast list)) + (cdr default)))) + (t + (default-constant-converter form)))))) (defun methods-converter (form generic-function) (cond ((and (consp form) (eq (car form) 'methods)) - (cons '.methods. - (get-effective-method-function1 generic-function (cadr form)))) - ((and (consp form) (eq (car form) 'unordered-methods)) - (default-secondary-dispatch-function generic-function)))) + (cons '.methods. + (get-effective-method-function1 generic-function (cadr form)))) + ((and (consp form) (eq (car form) 'unordered-methods)) + (default-secondary-dispatch-function generic-function)))) (defun convert-methods (constant method-alist wrappers) (if (and (consp constant) - (eq (car constant) '.methods.)) + (eq (car constant) '.methods.)) (funcall (cdr constant) method-alist wrappers) constant)) (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) - (eq (car constant) :mcase)) - (let ((alist (mapcar (lambda (k+m) - (cons (car k+m) - (convert-methods (cdr k+m) - method-alist - wrappers))) - (cddr constant))) - (mp (cadr constant))) - (ecase (cadr mp) - (:simple - (car alist)) - (:assoc - alist) - (:hash-table - (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) - (dolist (k+m alist) - (setf (gethash (car k+m) table) (cdr k+m))) - table))))))) + (eq (car constant) :mcase)) + (let ((alist (mapcar (lambda (k+m) + (cons (car k+m) + (convert-methods (cdr k+m) + method-alist + wrappers))) + (cddr constant))) + (mp (cadr constant))) + (ecase (cadr mp) + (:simple + (car alist)) + (:assoc + alist) + (:hash-table + (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) + (dolist (k+m alist) + (setf (gethash (car k+m) table) (cdr k+m))) + table))))))) (defun compute-secondary-dispatch-function1 (generic-function net - &optional function-p) + &optional function-p) (cond ((and (eq (car net) 'methods) (not function-p)) (get-effective-method-function1 generic-function (cadr net))) (t (let* ((name (generic-function-name generic-function)) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) - (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (fmc-arg-info (cons (length metatypes) applyp)) + (arglist (if function-p + (make-dfun-lambda-list metatypes applyp) + (make-fast-method-call-lambda-list metatypes applyp)))) (multiple-value-bind (cfunction constants) - (get-fun1 `(,(if function-p - 'instance-lambda - 'lambda) - ,arglist - ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) - (locally (declare #.*optimize-speed*) - (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf)))) - #'net-test-converter - #'net-code-converter - (lambda (form) - (net-constant-converter form generic-function))) - (lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-fun-name function `(sdfun-method ,name)) - :arg-info fmc-arg-info)))))))))) + (get-fun1 `(,(if function-p + 'instance-lambda + 'lambda) + ,arglist + ,@(unless function-p + `((declare (ignore .pv-cell. + .next-method-call.)))) + (locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf)))) + #'net-test-converter + #'net-code-converter + (lambda (form) + (net-constant-converter form generic-function))) + (lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-fun-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) (defun make-unordered-methods-emf (generic-function methods) (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~S~%" - (generic-function-name generic-function))) + (generic-function-name generic-function))) (lambda (&rest args) (let* ((types (types-from-args generic-function args 'eql)) - (smethods (sort-applicable-methods generic-function - methods - types)) - (emf (get-effective-method-function generic-function smethods))) + (smethods (sort-applicable-methods generic-function + methods + types)) + (emf (get-effective-method-function generic-function smethods))) (invoke-emf emf args)))) ;;; The value returned by compute-discriminating-function is a function @@ -1434,8 +1434,8 @@ ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) ;;; (lambda (arg) -;;; (print (list 'call-to-gf gf arg)) -;;; (funcall std arg)))) +;;; (print (list 'call-to-gf gf arg)) +;;; (funcall std arg)))) ;;; ;;; Because many discriminating functions would like to use a dynamic ;;; strategy in which the precise discriminating function changes with @@ -1461,29 +1461,29 @@ ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (lambda (arg) -;;; (cond ( -;;; -;;; (set-funcallable-instance-function -;;; gf -;;; (compute-discriminating-function gf)) -;;; (funcall gf arg)) -;;; (t -;;; )))) +;;; (cond ( +;;; +;;; (set-funcallable-instance-function +;;; gf +;;; (compute-discriminating-function gf)) +;;; (funcall gf arg)) +;;; (t +;;; )))) ;;; ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (lambda (arg) -;;; (cond ( -;;; (set-funcallable-instance-function -;;; gf -;;; (lambda (a) ..)) -;;; (funcall gf arg)) -;;; (t -;;; )))) +;;; (cond ( +;;; (set-funcallable-instance-function +;;; gf +;;; (lambda (a) ..)) +;;; (funcall gf arg)) +;;; (t +;;; )))) ;;; ;;; NOTE: All the examples above assume that all instances of the class -;;; my-generic-function accept only one argument. +;;; my-generic-function accept only one argument. (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) @@ -1501,41 +1501,41 @@ (with-slots (dfun-state arg-info) gf (typecase dfun-state (null (let ((name (generic-function-name gf))) - (when (eq name 'compute-applicable-methods) - (update-all-c-a-m-gf-info gf)) - (cond ((eq name 'slot-value-using-class) - (update-slot-value-gf-info gf 'reader) - #'slot-value-using-class-dfun) - ((equal name '(setf slot-value-using-class)) - (update-slot-value-gf-info gf 'writer) - #'setf-slot-value-using-class-dfun) - ((eq name 'slot-boundp-using-class) - (update-slot-value-gf-info gf 'boundp) - #'slot-boundp-using-class-dfun) - ((gf-precompute-dfun-and-emf-p arg-info) - (make-final-dfun gf)) - (t - (make-initial-dfun gf))))) + (when (eq name 'compute-applicable-methods) + (update-all-c-a-m-gf-info gf)) + (cond ((eq name 'slot-value-using-class) + (update-slot-value-gf-info gf 'reader) + #'slot-value-using-class-dfun) + ((equal name '(setf slot-value-using-class)) + (update-slot-value-gf-info gf 'writer) + #'setf-slot-value-using-class-dfun) + ((eq name 'slot-boundp-using-class) + (update-slot-value-gf-info gf 'boundp) + #'slot-boundp-using-class-dfun) + ((gf-precompute-dfun-and-emf-p arg-info) + (make-final-dfun gf)) + (t + (make-initial-dfun gf))))) (function dfun-state) (cons (car dfun-state))))) (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) - #|| (name (generic-function-name gf)) ||# - (arg-info (gf-arg-info gf))) + #|| (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) ; lest the cache be freed twice - (update-dfun gf dfun cache info)))))) + ((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) ; lest the cache be freed twice + (update-dfun gf dfun cache info)))))) (defmethod (setf class-name) :before (new-value (class class)) (let ((classoid (find-classoid (class-name class)))) @@ -1544,8 +1544,8 @@ (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (early-method-lambda-list method) + (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) @@ -1555,16 +1555,16 @@ (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) (remove-if (lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) - ll))) + (or (memq s keyword-parameters) + (eq s '&allow-other-keys))) + ll))) ;;; This is based on the rules of method lambda list congruency defined in ;;; the spec. The lambda list it constructs is the pretty union of the ;;; lambda lists of all the methods. It doesn't take method applicability ;;; into account at all yet. (defmethod generic-function-pretty-arglist - ((generic-function standard-generic-function)) + ((generic-function standard-generic-function)) (let ((methods (generic-function-methods generic-function))) (if methods (let ((arglist ())) @@ -1599,27 +1599,27 @@ (defmethod method-pretty-arglist ((method standard-method)) (let ((required ()) - (optional ()) - (rest nil) - (key ()) - (allow-other-keys nil) - (state 'required) - (arglist (method-lambda-list method))) + (optional ()) + (rest nil) + (key ()) + (allow-other-keys nil) + (state 'required) + (arglist (method-lambda-list method))) (dolist (arg arglist) (cond ((eq arg '&optional) (setq state 'optional)) ((eq arg '&rest) (setq state 'rest)) ((eq arg '&key) (setq state 'key)) ((eq arg '&allow-other-keys) (setq allow-other-keys t)) ((memq arg lambda-list-keywords)) - (t - (ecase state - (required (push arg required)) - (optional (push arg optional)) - (key (push arg key)) - (rest (setq rest arg)))))) + (t + (ecase state + (required (push arg required)) + (optional (push arg optional)) + (key (push arg key)) + (rest (setq rest arg)))))) (values (nreverse required) - (nreverse optional) - rest - (nreverse key) - allow-other-keys))) + (nreverse optional) + rest + (nreverse key) + allow-other-keys))) diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp index 6b15d73..ed8be04 100644 --- a/src/pcl/print-object.lisp +++ b/src/pcl/print-object.lisp @@ -68,45 +68,45 @@ (defmethod print-object ((method standard-method) stream) (print-unreadable-object (method stream :type t :identity t) (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method))) - (format stream "~S ~{~S ~}~:S" - (and generic-function - (generic-function-name generic-function)) - (method-qualifiers method) - (unparse-specializers method))) - ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and - ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)? - (call-next-method)))) + (let ((generic-function (method-generic-function method))) + (format stream "~S ~{~S ~}~:S" + (and generic-function + (generic-function-name generic-function)) + (method-qualifiers method) + (unparse-specializers method))) + ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and + ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)? + (call-next-method)))) (defmethod print-object ((method standard-accessor-method) stream) (print-unreadable-object (method stream :type t :identity t) (if (slot-boundp method 'generic-function) - (let ((generic-function (method-generic-function method))) - (format stream "~S, slot:~S, ~:S" - (and generic-function - (generic-function-name generic-function)) - (accessor-method-slot-name method) - (unparse-specializers method))) - (call-next-method)))) + (let ((generic-function (method-generic-function method))) + (format stream "~S, slot:~S, ~:S" + (and generic-function + (generic-function-name generic-function)) + (accessor-method-slot-name method) + (unparse-specializers method))) + (call-next-method)))) (defmethod print-object ((mc standard-method-combination) stream) (print-unreadable-object (mc stream :type t :identity t) (format stream - "~S ~S" - (slot-value-or-default mc 'type) - (slot-value-or-default mc 'options)))) + "~S ~S" + (slot-value-or-default mc 'type) + (slot-value-or-default mc 'options)))) (defun named-object-print-function (instance stream - &optional (extra nil extra-p)) + &optional (extra nil extra-p)) (print-unreadable-object (instance stream :type t) - (if extra-p - (format stream - "~S ~:S" - (slot-value-or-default instance 'name) - extra) - (format stream - "~S" - (slot-value-or-default instance 'name))))) + (if extra-p + (format stream + "~S ~:S" + (slot-value-or-default instance 'name) + extra) + (format stream + "~S" + (slot-value-or-default instance 'name))))) (defmethod print-object ((class class) stream) (named-object-print-function class stream)) @@ -119,16 +119,16 @@ generic-function stream (if (slot-boundp generic-function 'methods) - (list (length (generic-function-methods generic-function))) - "?"))) + (list (length (generic-function-methods generic-function))) + "?"))) (defmethod print-object ((cache cache) stream) (print-unreadable-object (cache stream :type t :identity t) (format stream - "~W ~S ~W" - (cache-nkeys cache) - (cache-valuep cache) - (cache-nlines cache)))) + "~W ~S ~W" + (cache-nkeys cache) + (cache-valuep cache) + (cache-nlines cache)))) (defmethod print-object ((wrapper wrapper) stream) (print-unreadable-object (wrapper stream :type t :identity t) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index dc7b804..66713bb 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -25,39 +25,39 @@ (defun ensure-accessor (type fun-name slot-name) (labels ((slot-missing-fun (slot-name type) - (let* ((method-type (ecase type - (slot-value 'reader-method) - (setf 'writer-method) - (slot-boundp 'boundp-method))) - (initargs - (copy-tree - (ecase type - (slot-value - (make-method-function - (lambda (obj) - (values - (slot-missing (class-of obj) obj slot-name - 'slot-value))))) - (slot-boundp - (make-method-function - (lambda (obj) - (not (not - (slot-missing (class-of obj) obj slot-name - 'slot-boundp)))))) - (setf - (make-method-function - (lambda (val obj) - (slot-missing (class-of obj) obj slot-name - 'setf val) - val))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) + (let* ((method-type (ecase type + (slot-value 'reader-method) + (setf 'writer-method) + (slot-boundp 'boundp-method))) + (initargs + (copy-tree + (ecase type + (slot-value + (make-method-function + (lambda (obj) + (values + (slot-missing (class-of obj) obj slot-name + 'slot-value))))) + (slot-boundp + (make-method-function + (lambda (obj) + (not (not + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))))) + (setf + (make-method-function + (lambda (val obj) + (slot-missing (class-of obj) obj slot-name + 'setf val) + val))))))) + (setf (getf (getf initargs :plist) :slot-name-lists) + (list (list nil slot-name))) + (setf (getf (getf initargs :plist) :pv-table-symbol) (gensym)) - (list* :method-spec (list method-type 'slot-object slot-name) + (list* :method-spec (list method-type 'slot-object slot-name) initargs))) - (add-slot-missing-method (gf slot-name type) - (multiple-value-bind (class lambda-list specializers) + (add-slot-missing-method (gf slot-name type) + (multiple-value-bind (class lambda-list specializers) (ecase type (slot-value (values 'standard-reader-method @@ -80,10 +80,10 @@ slot-name))))) (unless (fboundp fun-name) (let ((gf (ensure-generic-function - fun-name - :lambda-list (ecase type - ((reader boundp) '(object)) - (writer '(new-value object)))))) + fun-name + :lambda-list (ecase type + ((reader boundp) '(object)) + (writer '(new-value object)))))) (ecase type (reader (add-slot-missing-method gf slot-name 'slot-value)) (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) @@ -94,9 +94,9 @@ (defmacro accessor-slot-value (object slot-name) (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (reader-name (slot-reader-name slot-name))) + (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'reader ',reader-name ',slot-name)))) + (ensure-accessor 'reader ',reader-name ',slot-name)))) (declare (ignore .ignore.)) (truly-the (values t &optional) (funcall #',reader-name ,object))))) @@ -106,29 +106,29 @@ (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) (let* ((slot-name (eval slot-name)) - (bindings (unless (or (constantp new-value) (atom new-value)) - (let ((object-var (gensym))) - (prog1 `((,object-var ,object)) - (setq object object-var))))) - (writer-name (slot-writer-name slot-name)) - (form - `(let ((.ignore. - (load-time-value - (ensure-accessor 'writer ',writer-name ',slot-name))) - (.new-value. ,new-value)) - (declare (ignore .ignore.)) - (funcall #',writer-name .new-value. ,object) - .new-value.))) + (bindings (unless (or (constantp new-value) (atom new-value)) + (let ((object-var (gensym))) + (prog1 `((,object-var ,object)) + (setq object object-var))))) + (writer-name (slot-writer-name slot-name)) + (form + `(let ((.ignore. + (load-time-value + (ensure-accessor 'writer ',writer-name ',slot-name))) + (.new-value. ,new-value)) + (declare (ignore .ignore.)) + (funcall #',writer-name .new-value. ,object) + .new-value.))) (if bindings - `(let ,bindings ,form) - form))) + `(let ,bindings ,form) + form))) (defmacro accessor-slot-boundp (object slot-name) (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (boundp-name (slot-boundp-name slot-name))) + (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'boundp ',boundp-name ',slot-name)))) + (ensure-accessor 'boundp ',boundp-name ',slot-name)))) (declare (ignore .ignore.)) (funcall #',boundp-name ,object)))) @@ -147,20 +147,20 @@ (format s "~@" - (instance-structure-protocol-error-slotd c) - :instance :class - (cond - ((member (instance-structure-protocol-error-fun c) - '(slot-value-using-class slot-boundp-using-class)) - "read") - (t "written")) - (instance-structure-protocol-error-fun c))))) + (instance-structure-protocol-error-slotd c) + :instance :class + (cond + ((member (instance-structure-protocol-error-fun c) + '(slot-value-using-class slot-boundp-using-class)) + "read") + (t "written")) + (instance-structure-protocol-error-fun c))))) (defun instance-structure-protocol-error (slotd fun) (error 'instance-structure-protocol-error - :slotd slotd :fun fun - :references (list `(:amop :generic-function ,fun) - '(:amop :section (5 5 3))))) + :slotd slotd :fun fun + :references (list `(:amop :generic-function ,fun) + '(:amop :section (5 5 3))))) (defun get-optimized-std-accessor-method-function (class slotd name) (cond @@ -176,25 +176,25 @@ (boundp (slot-definition-boundp-function slotd)))) (t (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - ((std-class-p class) - ;; Shouldn't be using the optimized-std-accessors - ;; in this case. - #+nil (format t "* warning: ~S ~S~% ~S~%" - name slotd class) - nil) - (t (error "~S is not a STANDARD-CLASS." class)))) - (slot-name (slot-definition-name slotd)) - (location (slot-definition-location slotd)) - (function (ecase name - (reader #'make-optimized-std-reader-method-function) - (writer #'make-optimized-std-writer-method-function) - (boundp #'make-optimized-std-boundp-method-function))) - ;; KLUDGE: we need this slightly hacky calling convention - ;; for these functions for bootstrapping reasons: see - ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR, - ;; 2004-07-12 - (value (funcall function fsc-p slotd slot-name location))) + ((funcallable-standard-class-p class) t) + ((std-class-p class) + ;; Shouldn't be using the optimized-std-accessors + ;; in this case. + #+nil (format t "* warning: ~S ~S~% ~S~%" + name slotd class) + nil) + (t (error "~S is not a STANDARD-CLASS." class)))) + (slot-name (slot-definition-name slotd)) + (location (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + ;; KLUDGE: we need this slightly hacky calling convention + ;; for these functions for bootstrapping reasons: see + ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR, + ;; 2004-07-12 + (value (funcall function fsc-p slotd slot-name location))) (declare (type function function)) (values value (slot-definition-location slotd)))))) @@ -205,32 +205,32 @@ (etypecase location (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values - (slot-unbound (class-of instance) instance slot-name)) - value))) - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values - (slot-unbound (class-of instance) instance slot-name)) - value))))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))))) (cons (lambda (instance) - (check-obsolete-instance instance) - (let ((value (cdr location))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) instance slot-name)) - value)))) + (check-obsolete-instance instance) + (let ((value (cdr location))) + (if (eq value +slot-unbound+) + (values (slot-unbound (class-of instance) instance slot-name)) + value)))) (null (lambda (instance) - (instance-structure-protocol-error slotd 'slot-value-using-class)))) + (instance-structure-protocol-error slotd 'slot-value-using-class)))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function @@ -239,24 +239,24 @@ (set-fun-name (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)))) + (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))) + (check-obsolete-instance instance) + (setf (cdr location) nv))) (null (lambda (nv instance) - (declare (ignore nv)) - (instance-structure-protocol-error slotd - '(setf slot-value-using-class))))) + (declare (ignore nv)) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class))))) `(writer ,slot-name))) (defun make-optimized-std-boundp-method-function @@ -265,22 +265,22 @@ (set-fun-name (etypecase location (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) - location) - +slot-unbound+))) - (lambda (instance) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) - location) - +slot-unbound+))))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) + location) + +slot-unbound+))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) + location) + +slot-unbound+))))) (cons (lambda (instance) - (check-obsolete-instance instance) - (not (eq (cdr location) +slot-unbound+)))) + (check-obsolete-instance instance) + (not (eq (cdr location) +slot-unbound+)))) (null (lambda (instance) - (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) + (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) `(boundp ,slot-name))) (defun make-optimized-structure-slot-value-using-class-method-function @@ -308,79 +308,79 @@ ((structure-class-p class) (ecase name (reader (make-optimized-structure-slot-value-using-class-method-function - (slot-definition-internal-reader-function slotd))) + (slot-definition-internal-reader-function slotd))) (writer (make-optimized-structure-setf-slot-value-using-class-method-function - (slot-definition-internal-writer-function slotd))) + (slot-definition-internal-writer-function slotd))) (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))) ((condition-class-p class) (ecase name (reader - (let ((fun (slot-definition-reader-function slotd))) - (declare (type function fun)) - (lambda (class object slotd) - (declare (ignore class slotd)) - (funcall fun object)))) + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))) (writer - (let ((fun (slot-definition-writer-function slotd))) - (declare (type function fun)) - (lambda (new-value class object slotd) - (declare (ignore class slotd)) - (funcall fun new-value object)))) + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (lambda (new-value class object slotd) + (declare (ignore class slotd)) + (funcall fun new-value object)))) (boundp - (let ((fun (slot-definition-boundp-function slotd))) - (declare (type function fun)) - (lambda (class object slotd) - (declare (ignore class slotd)) - (funcall fun object)))))) + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))))) (t (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~S is not a standard-class" class)))) - (function - (ecase name - (reader - #'make-optimized-std-slot-value-using-class-method-function) - (writer - #'make-optimized-std-setf-slot-value-using-class-method-function) - (boundp - #'make-optimized-std-slot-boundp-using-class-method-function)))) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) (declare (type function function)) (values (funcall function fsc-p slotd) - (slot-definition-location slotd)))))) + (slot-definition-location slotd)))))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) (let ((location (slot-definition-location slotd)) - (slot-name (slot-definition-name slotd))) + (slot-name (slot-definition-name slotd))) (etypecase location (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))) - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))))) (cons (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (cdr location))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value)))) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (cdr location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value)))) (null (lambda (class instance slotd) - (declare (ignore class instance)) - (instance-structure-protocol-error slotd 'slot-value-using-class)))))) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd 'slot-value-using-class)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slotd) @@ -389,24 +389,24 @@ (etypecase location (fixnum (if fsc-p - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) location) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) location) - nv)))) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)))) (cons (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (cdr location) nv))) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (cdr location) nv))) (null (lambda (nv class instance slotd) - (declare (ignore nv class instance)) - (instance-structure-protocol-error - slotd '(setf slot-value-using-class))))))) + (declare (ignore nv class instance)) + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defun make-optimized-std-slot-boundp-using-class-method-function (fsc-p slotd) @@ -415,133 +415,133 @@ (etypecase location (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) location) - +slot-unbound+))) - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) location) - +slot-unbound+))))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) location) + +slot-unbound+))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) location) + +slot-unbound+))))) (cons (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (cdr location) +slot-unbound+)))) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (cdr location) +slot-unbound+)))) (null (lambda (class instance slotd) - (declare (ignore class instance)) - (instance-structure-protocol-error slotd - 'slot-boundp-using-class)))))) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd + 'slot-boundp-using-class)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) - `(invoke-effective-method-function ,emf nil ,@args))) + `(invoke-effective-method-function ,emf nil ,@args))) (set-fun-name (case name (reader (lambda (instance) - (emf-funcall sdfun class instance slotd))) + (emf-funcall sdfun class instance slotd))) (writer (lambda (nv instance) - (emf-funcall sdfun nv class instance slotd))) + (emf-funcall sdfun nv class instance slotd))) (boundp (lambda (instance) - (emf-funcall sdfun class instance slotd)))) + (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 - (lambda (instance) - (let ((wrapper (get-instance-wrapper-or-nil instance))) - (if wrapper - (let* ((class (wrapper-class* wrapper)) - (index (or (instance-slot-index wrapper slot-name) - (assq slot-name - (wrapper-class-slots wrapper))))) - (typecase index - (fixnum - (let ((value (clos-slots-ref (get-slots instance) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (cons - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (values (slot-unbound (class-of instance) - instance - slot-name)) - value))) - (t - (error "~@" - class slot-name)))) - (slot-value instance slot-name))))))) + class slot-name)))) + (slot-value instance slot-name))))))) (defun make-std-reader-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-read-internal - .pv. instance-slots 1 - (slot-value instance slot-name)))))))) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-read-internal + .pv. instance-slots 1 + (slot-value instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) + (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(reader-method ,class-name ,slot-name) - initargs))) + initargs))) (defun make-std-writer-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 1 nv - (setf (slot-value instance slot-name) nv)))))))) + (initargs (copy-tree + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 1 nv + (setf (slot-value instance slot-name) nv)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list nil (list nil slot-name))) + (list nil (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(writer-method ,class-name ,slot-name) - initargs))) + initargs))) (defun make-std-boundp-method-function (class-name slot-name) (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-boundp-internal - .pv. instance-slots 1 - (slot-boundp instance slot-name)))))))) + (initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 (.pv. .calls. + (symbol-value pv-table-symbol) + (instance) (instance-slots)) + (instance-boundp-internal + .pv. instance-slots 1 + (slot-boundp instance slot-name)))))))) (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) + (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) (list* :method-spec `(boundp-method ,class-name ,slot-name) - initargs))) + initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type) (macrolet ((frob (type name-fun add-fun ll) - `(when (or (null type) (eq type ',type)) - (let* ((name (,name-fun slot-name)) - (gf (ensure-generic-function name - :lambda-list ',ll)) - (methods (generic-function-methods gf))) - (when (or (null methods) - (plist-value gf 'slot-missing-method)) - (setf (plist-value gf 'slot-missing-method) nil) - (,add-fun *the-class-slot-object* gf slot-name)))))) + `(when (or (null type) (eq type ',type)) + (let* ((name (,name-fun slot-name)) + (gf (ensure-generic-function name + :lambda-list ',ll)) + (methods (generic-function-methods gf))) + (when (or (null methods) + (plist-value gf 'slot-missing-method)) + (setf (plist-value gf 'slot-missing-method) nil) + (,add-fun *the-class-slot-object* gf slot-name)))))) (frob reader slot-reader-name add-reader-method (object)) (frob writer slot-writer-name add-writer-method (new-value object)) (frob boundp slot-boundp-name add-boundp-method (object)))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 24de706..f833fce 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -28,9 +28,9 @@ (define-condition unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance)) (:report (lambda (condition stream) - (format stream "The slot ~S is unbound in the object ~S." - (cell-error-name condition) - (unbound-slot-instance condition))))) + (format stream "The slot ~S is unbound in the object ~S." + (cell-error-name condition) + (unbound-slot-instance condition))))) (defmethod wrapper-fetcher ((class standard-class)) 'std-instance-wrapper) @@ -50,30 +50,30 @@ (defun set-wrapper (inst new) (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) new)) - (t - (error "unrecognized instance type")))) + (setf (std-instance-wrapper inst) new)) + ((fsc-instance-p inst) + (setf (fsc-instance-wrapper inst) new)) + (t + (error "unrecognized instance type")))) (defun swap-wrappers-and-slots (i1 i2) - (with-pcl-lock ;FIXME is this sufficient? + (with-pcl-lock ;FIXME is this sufficient? (cond ((std-instance-p i1) - (let ((w1 (std-instance-wrapper i1)) - (s1 (std-instance-slots i1))) - (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) - (setf (std-instance-slots i1) (std-instance-slots i2)) - (setf (std-instance-wrapper i2) w1) - (setf (std-instance-slots i2) s1))) - ((fsc-instance-p i1) - (let ((w1 (fsc-instance-wrapper i1)) - (s1 (fsc-instance-slots i1))) - (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) - (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) - (setf (fsc-instance-wrapper i2) w1) - (setf (fsc-instance-slots i2) s1))) - (t - (error "unrecognized instance type"))))) + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1))) + ((fsc-instance-p i1) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1))) + (t + (error "unrecognized instance type"))))) (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) @@ -83,53 +83,53 @@ (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (values (slot-missing class object slot-name 'slot-value)) - (slot-value-using-class class object slot-definition)))) + (values (slot-missing class object slot-name 'slot-value)) + (slot-value-using-class class object slot-definition)))) (define-compiler-macro slot-value (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-slot-value ,object ,slot-name) form)) (defun set-slot-value (object slot-name new-value) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (progn (slot-missing class object slot-name 'setf new-value) - new-value) - (setf (slot-value-using-class class object slot-definition) - new-value)))) + (progn (slot-missing class object slot-name 'setf new-value) + new-value) + (setf (slot-value-using-class class object slot-definition) + new-value)))) (define-compiler-macro set-slot-value (&whole form object slot-name new-value) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) (defun slot-boundp (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (not (not (slot-missing class object slot-name 'slot-boundp))) - (slot-boundp-using-class class object slot-definition)))) + (not (not (slot-missing class object slot-name 'slot-boundp))) + (slot-boundp-using-class class object slot-definition)))) (setf (gdefinition 'slot-boundp-normal) #'slot-boundp) (define-compiler-macro slot-boundp (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (eval slot-name))) `(accessor-slot-boundp ,object ,slot-name) form)) (defun slot-makunbound (object slot-name) (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) + (slot-definition (find-slot-definition class slot-name))) (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)) + (slot-missing class object slot-name 'slot-makunbound) + (slot-makunbound-using-class class object slot-definition)) object)) (defun slot-exists-p (object slot-name) @@ -150,97 +150,97 @@ (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (object std-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (bug "unrecognized instance type in ~S" - 'slot-value-using-class)))) - (cons - (cdr location)) - (t - (instance-structure-protocol-error slotd - 'slot-value-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-value-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-value-using-class))))) (if (eq value +slot-unbound+) - (values (slot-unbound class object (slot-definition-name slotd))) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) - (new-value (class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (new-value (class std-class) + (object std-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) + (setf (clos-slots-ref (std-instance-slots object) location) + new-value)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + new-value)) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) (cons (setf (cdr location) new-value)) (t (instance-structure-protocol-error slotd - '(setf slot-value-using-class)))))) + '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object std-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value - (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (bug "unrecognized instance type in ~S" - 'slot-boundp-using-class)))) - (cons - (cdr location)) - (t - (instance-structure-protocol-error slotd - 'slot-boundp-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-boundp-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-boundp-using-class))))) (not (eq value +slot-unbound+)))) (defmethod slot-makunbound-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object std-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - +slot-unbound+)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - +slot-unbound+)) - (t (bug "unrecognized instance type in ~S" - 'slot-makunbound-using-class)))) + (setf (clos-slots-ref (std-instance-slots object) location) + +slot-unbound+)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + +slot-unbound+)) + (t (bug "unrecognized instance type in ~S" + 'slot-makunbound-using-class)))) (cons (setf (cdr location) +slot-unbound+)) (t (instance-structure-protocol-error slotd - 'slot-makunbound-using-class)))) + 'slot-makunbound-using-class)))) object) (defmethod slot-value-using-class @@ -270,52 +270,52 @@ (defmethod slot-makunbound-using-class ((class condition-class) object slot) (error "attempt to unbind slot ~S in condition object ~S." - slot object)) + slot object)) (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (let* ((function (slot-definition-internal-reader-function slotd)) - (value (funcall function object))) + (value (funcall function object))) (declare (type function function)) (if (eq value +slot-unbound+) - (values (slot-unbound class object (slot-definition-name slotd))) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + (object structure-object) + (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) (declare (type function function)) (funcall function new-value object))) (defmethod slot-boundp-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) t) (defmethod slot-makunbound-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) (error "Structure slots can't be unbound.")) (defmethod slot-missing - ((class t) instance slot-name operation &optional new-value) + ((class t) instance slot-name operation &optional new-value) (error "~@" - (ecase operation - (slot-value "read the slot's value (slot-value)") - (setf (format nil - "set the slot's value to ~S (SETF of SLOT-VALUE)" - new-value)) - (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") - (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) - slot-name - instance)) + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil + "set the slot's value to ~S (SETF of SLOT-VALUE)" + new-value)) + (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") + (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) + slot-name + instance)) (defmethod slot-unbound ((class t) instance slot-name) (error 'unbound-slot :name slot-name :instance instance)) @@ -336,7 +336,7 @@ ;;; care of this for non-standard-classes.x (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) - (unless (class-finalized-p class) + (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-standard-instance (class-wrapper class))) @@ -344,7 +344,7 @@ (declare (ignore initargs)) (let ((constructor (class-defstruct-constructor class))) (if constructor - (funcall constructor) + (funcall constructor) (allocate-standard-instance (class-wrapper class))))) ;;; FIXME: It would be nicer to have allocate-instance return diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 41b4390..d5d906b 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -30,8 +30,8 @@ (boundp (slot-definition-boundp-function slotd)))) (defmethod (setf slot-accessor-function) (function - (slotd effective-slot-definition) - type) + (slotd effective-slot-definition) + type) (ecase type (reader (setf (slot-definition-reader-function slotd) function)) (writer (setf (slot-definition-writer-function slotd) function)) @@ -46,44 +46,44 @@ (let ((flags (slot-value slotd 'accessor-flags))) (declare (type fixnum flags)) (if (eq type 'all) - (eql +slotd-all-function-std-p+ flags) - (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+)))) - (declare (type fixnum mask)) - (not (zerop (the fixnum (logand mask flags)))))))) + (eql +slotd-all-function-std-p+ flags) + (let ((mask (ecase type + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+)))) + (declare (type fixnum mask)) + (not (zerop (the fixnum (logand mask flags)))))))) (defmethod (setf slot-accessor-std-p) (value - (slotd effective-slot-definition) - type) + (slotd effective-slot-definition) + type) (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+))) - (flags (slot-value slotd 'accessor-flags))) + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+))) + (flags (slot-value slotd 'accessor-flags))) (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) - (if value - (the fixnum (logior mask flags)) - (the fixnum (logand (the fixnum (lognot mask)) flags))))) + (if value + (the fixnum (logior mask flags)) + (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) (defmethod initialize-internal-slot-functions ((slotd - effective-slot-definition)) + effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) + (class (slot-value slotd 'class))) (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) + (setf (gethash name *name->class->slotd-table*) + (make-hash-table :test 'eq :size 5))))) (setf (gethash class table) slotd)) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type - (reader 'slot-value-using-class) - (writer '(setf slot-value-using-class)) - (boundp 'slot-boundp-using-class))) - (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + (compute-slot-accessor-info slotd type gf))) (initialize-internal-slot-gfs name))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: @@ -101,15 +101,15 @@ ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, ;;; or some such. (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) - type gf) + type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) - (old-slotd (find-slot-definition class name)) - (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (class (slot-value slotd 'class)) + (old-slotd (find-slot-definition class name)) + (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) (multiple-value-bind (function std-p) - (if (eq *boot-state* 'complete) - (get-accessor-method-function gf type class slotd) - (get-optimized-std-accessor-method-function class slotd type)) + (if (eq *boot-state* 'complete) + (get-accessor-method-function gf type class slotd) + (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)) (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) @@ -131,7 +131,7 @@ (macrolet ((def (class) `(defmethod class-prototype ((class ,class)) (with-slots (prototype) class - (or prototype + (or prototype (setf prototype (allocate-instance class))))))) (def std-class) (def condition-class) @@ -180,13 +180,13 @@ ;;; computed lazily. (defmethod add-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer - (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH - (cdr direct-methods) ())) + (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH + (cdr direct-methods) ())) method) (defmethod remove-direct-method ((specializer class) (method method)) (with-slots (direct-methods) specializer (setf (car direct-methods) (remove method (car direct-methods)) - (cdr direct-methods) ())) + (cdr direct-methods) ())) method) (defmethod specializer-direct-methods ((specializer class)) @@ -196,12 +196,12 @@ (defmethod specializer-direct-generic-functions ((specializer class)) (with-slots (direct-methods) specializer (or (cdr direct-methods) - (setf (cdr direct-methods) - (let (collect) - (dolist (m (car direct-methods)) + (setf (cdr direct-methods) + (let (collect) + (dolist (m (car direct-methods)) ;; the old PCL code used COLLECTING-ONCE which used ;; #'EQ to check for newness - (pushnew (method-generic-function m) collect :test #'eq)) + (pushnew (method-generic-function m) collect :test #'eq)) (nreverse collect)))))) ;;; This hash table is used to store the direct methods and direct generic @@ -216,70 +216,70 @@ *class-eq-specializer-methods*) (defmethod add-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (table (specializer-method-table specializer)) - (entry (gethash object table))) + (table (specializer-method-table specializer)) + (entry (gethash object table))) (unless entry (setq entry - (setf (gethash object table) - (cons nil nil)))) + (setf (gethash object table) + (cons nil nil)))) (setf (car entry) (adjoin method (car entry)) - (cdr entry) ()) + (cdr entry) ()) method)) (defmethod remove-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry (setf (car entry) (remove method (car entry)) - (cdr entry) ())) + (cdr entry) ())) method)) (defmethod specializer-direct-methods ((specializer specializer-with-object)) (car (gethash (specializer-object specializer) - (specializer-method-table specializer)))) + (specializer-method-table specializer)))) (defmethod specializer-direct-generic-functions ((specializer - specializer-with-object)) + specializer-with-object)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) - (setf (cdr entry) - (let (collect) - (dolist (m (car entry)) - (pushnew (method-generic-function m) collect :test #'eq)) + (setf (cdr entry) + (let (collect) + (dolist (m (car entry)) + (pushnew (method-generic-function m) collect :test #'eq)) (nreverse collect))))))) (defun map-specializers (function) (map-all-classes (lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) + (funcall function (class-eq-specializer class)) + (funcall function class))) (maphash (lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) - *eql-specializer-methods*) + (declare (ignore methods)) + (intern-eql-specializer object)) + *eql-specializer-methods*) (maphash (lambda (object specl) - (declare (ignore object)) - (funcall function specl)) - *eql-specializer-table*) + (declare (ignore object)) + (funcall function specl)) + *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) (map-specializers (lambda (specl) - (dolist (gf (specializer-direct-generic-functions - specl)) - (unless (gethash gf all-generic-functions) - (setf (gethash gf all-generic-functions) t) - (funcall function gf)))))) + (dolist (gf (specializer-direct-generic-functions + specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) - slot-names - &key) + slot-names + &key) (declare (ignore slot-names)) (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) @@ -306,12 +306,12 @@ (defun ensure-class (name &rest args) (apply #'ensure-class-using-class - (let ((class (find-class name nil))) - (when (and class (eq name (class-name class))) - ;; NAME is the proper name of CLASS, so redefine it - class)) - name - args)) + (let ((class (find-class name nil))) + (when (and class (eq name (class-name class))) + ;; NAME is the proper name of CLASS, so redefine it + class)) + name + args)) (defmethod ensure-class-using-class ((class null) name &rest args &key) (multiple-value-bind (meta initargs) @@ -340,26 +340,26 @@ (defun fix-super (s) (cond ((classp s) s) ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) + (error "~S is not a class or a legal class name." s)) (t - (or (find-class s nil) - (make-instance 'forward-referenced-class - :name s))))) + (or (find-class s nil) + (make-instance 'forward-referenced-class + :name s))))) (defun ensure-class-values (class initargs) (let (metaclass metaclassp reversed-plist) (doplist (key val) initargs (cond ((eq key :metaclass) - (setf metaclass val - metaclassp key)) - (t - (when (eq key :direct-superclasses) - (setf val (mapcar #'fix-super val))) - (setf reversed-plist (list* val key reversed-plist))))) + (setf metaclass val + metaclassp key)) + (t + (when (eq key :direct-superclasses) + (setf val (mapcar #'fix-super val))) + (setf reversed-plist (list* val key reversed-plist))))) (values (cond (metaclassp - (if (classp metaclass) - metaclass - (find-class metaclass))) + (if (classp metaclass) + metaclass + (find-class metaclass))) ((or (null class) (forward-referenced-class-p class)) *the-class-standard-class*) (t @@ -368,93 +368,93 @@ (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) + slot-names + &key (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + (predicate-name nil predicate-name-p)) (cond (direct-superclasses-p - (setq direct-superclasses - (or direct-superclasses - (list (if (funcallable-standard-class-p class) - *the-class-funcallable-standard-object* - *the-class-standard-object*)))) - (dolist (superclass direct-superclasses) - (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." - superclass class (class-of superclass) (class-of class) - 'validate-superclass))) - (setf (slot-value class 'direct-superclasses) direct-superclasses)) - (t - (setq direct-superclasses (slot-value class 'direct-superclasses)))) + (setq direct-superclasses + (or direct-superclasses + (list (if (funcallable-standard-class-p class) + *the-class-funcallable-standard-object* + *the-class-standard-object*)))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "The class ~S was specified as a~% + super-class of the class ~S;~%~ + but the meta-classes ~S and~%~S are incompatible.~@ + Define a method for ~S to avoid this error." + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) + (setf (slot-value class 'direct-superclasses) direct-superclasses)) + (t + (setq direct-superclasses (slot-value class 'direct-superclasses)))) (setq direct-slots - (if direct-slots-p - (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) - (slot-value class 'direct-slots))) + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) + (slot-value class 'direct-slots))) (if direct-default-initargs-p (setf (plist-value class 'direct-default-initargs) - direct-default-initargs) + direct-default-initargs) (setq direct-default-initargs - (plist-value class 'direct-default-initargs))) + (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) - (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) - (collect '())) - (dolist (dslotd direct-slots) - (when (eq :class (slot-definition-allocation dslotd)) - ;; see CLHS 4.3.6 - (let* ((name (slot-definition-name dslotd)) - (old (assoc name old-class-slot-cells))) - (if (or (not old) - (eq t slot-names) - (member name slot-names)) - (let* ((initfunction (slot-definition-initfunction dslotd)) - (value (if initfunction - (funcall initfunction) - +slot-unbound+))) - (push (cons name value) collect)) - (push old collect))))) + (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (collect '())) + (dolist (dslotd direct-slots) + (when (eq :class (slot-definition-allocation dslotd)) + ;; see CLHS 4.3.6 + (let* ((name (slot-definition-name dslotd)) + (old (assoc name old-class-slot-cells))) + (if (or (not old) + (eq t slot-names) + (member name slot-names)) + (let* ((initfunction (slot-definition-initfunction dslotd)) + (value (if initfunction + (funcall initfunction) + +slot-unbound+))) + (push (cons name value) collect)) + (push old collect))))) (nreverse collect))) (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) + (setf (slot-value class 'predicate-name) + (car predicate-name)) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) + (make-class-predicate-name (class-name + class)))))) (add-direct-subclasses class direct-superclasses) (make-class-predicate class predicate-name) (update-class class nil) (do* ((slots (slot-value class 'slots) (cdr slots)) - (dupes nil)) + (dupes nil)) ((null slots) (when dupes - (style-warn - ;; FIXME: the indentation request ("~4I") - ;; below appears not to do anything. Finding - ;; out why would be nice. -- CSR, 2003-04-24 - "~@~@:>" - class - dupes))) + class + dupes))) (let* ((slot (car slots)) - (oslots (remove (slot-definition-name slot) (cdr slots) - :test #'string/= :key #'slot-definition-name))) + (oslots (remove (slot-definition-name slot) (cdr slots) + :test #'string/= :key #'slot-definition-name))) (when oslots - (pushnew (cons (slot-definition-name slot) - (mapcar #'slot-definition-name oslots)) - dupes - :test #'string= :key #'car)))) + (pushnew (cons (slot-definition-name slot) + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car)))) (add-slot-accessors class direct-slots) (make-preliminary-layout class)) (defmethod shared-initialize :after ((class forward-referenced-class) - slot-names &key &allow-other-keys) + slot-names &key &allow-other-keys) (declare (ignore slot-names)) (make-preliminary-layout class)) @@ -464,35 +464,35 @@ ;;; make it known to the type system. (defun make-preliminary-layout (class) (flet ((compute-preliminary-cpl (root) - (let ((*allow-forward-referenced-classes-in-cpl-p* t)) - (compute-class-precedence-list root)))) + (let ((*allow-forward-referenced-classes-in-cpl-p* t)) + (compute-class-precedence-list root)))) (without-package-locks (unless (class-finalized-p class) (let ((name (class-name class))) - (setf (find-class name) class) - ;; KLUDGE: This is fairly horrible. We need to make a - ;; full-fledged CLASSOID here, not just tell the compiler that - ;; some class is forthcoming, because there are legitimate - ;; questions one can ask of the type system, implemented in - ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (when (and (eq *boot-state* 'complete) - (null (find-classoid name nil))) - (setf (find-classoid name) - (make-standard-classoid :name name))) - (set-class-type-translation class name) - (let ((layout (make-wrapper 0 class)) - (classoid (find-classoid name))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) - (setf (slot-value class 'wrapper) layout) - (let ((cpl (compute-preliminary-cpl class))) - (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout) - (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) + (setf (find-class name) class) + ;; KLUDGE: This is fairly horrible. We need to make a + ;; full-fledged CLASSOID here, not just tell the compiler that + ;; some class is forthcoming, because there are legitimate + ;; questions one can ask of the type system, implemented in + ;; terms of CLASSOIDs, involving forward-referenced classes. So. + (when (and (eq *boot-state* 'complete) + (null (find-classoid name nil))) + (setf (find-classoid name) + (make-standard-classoid :name name))) + (set-class-type-translation class name) + (let ((layout (make-wrapper 0 class)) + (classoid (find-classoid name))) + (setf (layout-classoid layout) classoid) + (setf (classoid-pcl-class classoid) class) + (setf (slot-value class 'wrapper) layout) + (let ((cpl (compute-preliminary-cpl class))) + (setf (layout-inherits layout) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) + (register-layout layout :invalidate t) + (setf (classoid-layout classoid) layout) + (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -501,7 +501,7 @@ ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) (setf (slot-value class 'type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) - (make-instance 'class-eq-specializer :class class))) + (make-instance 'class-eq-specializer :class class))) (defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses) (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses)) @@ -509,23 +509,23 @@ (remove-slot-accessors class (class-direct-slots class))) (defmethod reinitialize-instance :after ((class slot-class) - &rest initargs - &key) + &rest initargs + &key) (map-dependents class - (lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-slots direct-superclasses) + &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (class-name class)))) (with-slots (wrapper class-precedence-list cpl-available-p prototype predicate-name - (direct-supers direct-superclasses)) - class + (direct-supers direct-superclasses)) + class (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) (setf (slot-value class 'finalized-p) t) (setf (classoid-pcl-class classoid) class) (setq direct-supers direct-superclasses) @@ -544,12 +544,12 @@ (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-direct-slot-definition)) (defmethod effective-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-effective-slot-definition)) @@ -561,30 +561,30 @@ ((class condition-class) slot-name dslotds) (let ((slotd (call-next-method))) (setf (slot-definition-reader-function slotd) - (lambda (x) - (handler-case (condition-reader-function x slot-name) - ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot - ;; is unbound; maybe it should be a CELL-ERROR of some - ;; sort? - (error () (values (slot-unbound class x slot-name)))))) + (lambda (x) + (handler-case (condition-reader-function x slot-name) + ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot + ;; is unbound; maybe it should be a CELL-ERROR of some + ;; sort? + (error () (values (slot-unbound class x slot-name)))))) (setf (slot-definition-writer-function slotd) - (lambda (v x) - (condition-writer-function x v slot-name))) + (lambda (v x) + (condition-writer-function x v slot-name))) (setf (slot-definition-boundp-function slotd) - (lambda (x) - (multiple-value-bind (v c) - (ignore-errors (condition-reader-function x slot-name)) - (declare (ignore v)) - (null c)))) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors (condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) slotd)) (defmethod compute-slots ((class condition-class)) (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class (slot-definition-name dslotd) (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) @@ -614,13 +614,13 @@ direct-slots))) (reader-names (mapcar (lambda (slotd) (list 'slot-accessor name - (slot-definition-name slotd) - 'reader)) + (slot-definition-name slotd) + 'reader)) direct-slots)) (writer-names (mapcar (lambda (slotd) (list 'slot-accessor name - (slot-definition-name slotd) - 'writer)) + (slot-definition-name slotd) + 'writer)) direct-slots)) (readers-init (mapcar (lambda (slotd reader-name) @@ -663,47 +663,47 @@ (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) - (or direct-superclasses - (setq direct-superclasses - (and (not (eq (class-name class) 'structure-object)) - (list *the-class-structure-object*))))) + (or direct-superclasses + (setq direct-superclasses + (and (not (eq (class-name class) 'structure-object)) + (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) (let* ((name (class-name class)) - (from-defclass-p (slot-value class 'from-defclass-p)) - (defstruct-p (or from-defclass-p (not (structure-type-p name))))) + (from-defclass-p (slot-value class 'from-defclass-p)) + (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (if direct-slots-p - (setf (slot-value class 'direct-slots) - (setq direct-slots - (mapcar (lambda (pl) - (when defstruct-p - (let* ((slot-name (getf pl :name)) - (accessor - (format-symbol *package* - "~S structure class ~A" - name slot-name))) - (setq pl (list* :defstruct-accessor-symbol - accessor pl)))) - (make-direct-slotd class pl)) - direct-slots))) - (setq direct-slots (slot-value class 'direct-slots))) + (setf (slot-value class 'direct-slots) + (setq direct-slots + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (accessor + (format-symbol *package* + "~S structure class ~A" + name slot-name))) + (setq pl (list* :defstruct-accessor-symbol + accessor pl)))) + (make-direct-slotd class pl)) + direct-slots))) + (setq direct-slots (slot-value class 'direct-slots))) (if defstruct-p - (let ((include (car (slot-value class 'direct-superclasses)))) - (multiple-value-bind (defstruct-form constructor reader-names writer-names) - (make-structure-class-defstruct-form name direct-slots include) - (unless (structure-type-p name) (eval defstruct-form)) - (mapc (lambda (dslotd reader-name writer-name) - (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) - reader) - (setf (slot-value dslotd 'internal-writer-function) - writer))) - direct-slots reader-names writer-names) - (setf (slot-value class 'defstruct-form) defstruct-form) - (setf (slot-value class 'defstruct-constructor) constructor))) - (setf (slot-value class 'defstruct-constructor) - (make-defstruct-allocation-function class))) + (let ((include (car (slot-value class 'direct-superclasses)))) + (multiple-value-bind (defstruct-form constructor reader-names writer-names) + (make-structure-class-defstruct-form name direct-slots include) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc (lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (gboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor))) + (setf (slot-value class 'defstruct-constructor) + (make-defstruct-allocation-function class))) (add-direct-subclasses class direct-superclasses) (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) @@ -715,10 +715,10 @@ (setf (slot-value class 'finalized-p) t) (update-pv-table-cache-info class) (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) + (or (slot-value class 'predicate-name) + (setf (slot-value class 'predicate-name) (make-class-predicate-name (class-name class)))))) (make-class-predicate class predicate-name) @@ -741,9 +741,9 @@ (flet ((fix (gfspec name r/w) (let ((gf (cond ((eq add/remove 'add) (if (fboundp gfspec) - (without-package-locks + (without-package-locks (ensure-generic-function gfspec)) - (ensure-generic-function + (ensure-generic-function gfspec :lambda-list (case r/w (r '(object)) (w '(new-value object)))))) @@ -761,9 +761,9 @@ (remove-writer-method class gf)))))))) (dolist (dslotd dslotds) (let ((slot-name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) + (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) - (dolist (w (slot-definition-writers dslotd)) + (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) (defun add-direct-subclasses (class supers) @@ -788,7 +788,7 @@ (defun class-has-a-forward-referenced-superclass-p (class) (or (forward-referenced-class-p class) (some #'class-has-a-forward-referenced-superclass-p - (class-direct-superclasses class)))) + (class-direct-superclasses class)))) ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. @@ -800,12 +800,12 @@ ;; problems. (without-package-locks (when (and (not finalizep) - (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) + (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) (finalize-inheritance class) (return-from update-class)) (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) + (not (class-has-a-forward-referenced-superclass-p class))) (setf (find-class (class-name class)) class) (update-cpl class (compute-class-precedence-list class)) ;; This invocation of UPDATE-SLOTS, in practice, finalizes the @@ -823,16 +823,16 @@ (defun update-cpl (class cpl) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) - (dolist (c cpl t) - (when (position :class (class-direct-slots c) - :key #'slot-definition-allocation) - (return nil)))) - ;; comment from the old CMU CL sources: - ;; Need to have the cpl setup before update-lisp-class-layout - ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) + ;; comment from the old CMU CL sources: + ;; Need to have the cpl setup before update-lisp-class-layout + ;; is called on CMU CL. + (setf (slot-value class 'class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t) - (force-cache-flushes class)) + (force-cache-flushes class)) (progn (setf (slot-value class 'class-precedence-list) cpl) (setf (slot-value class 'cpl-available-p) t))) @@ -842,7 +842,7 @@ (when cpl (let ((first (car cpl))) (dolist (c (cdr cpl)) - (pushnew c (slot-value first 'can-precede-list)))) + (pushnew c (slot-value first 'can-precede-list)))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) @@ -850,54 +850,54 @@ (defun update-slots (class eslotds) (let ((instance-slots ()) - (class-slots ())) + (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) - (case alloc + (case alloc (:instance (push eslotd instance-slots)) (:class (push eslotd class-slots))))) ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. (let* ((nlayout (mapcar #'slot-definition-name - (sort instance-slots #'< - :key #'slot-definition-location))) - (nslots (length nlayout)) - (nwrapper-class-slots (compute-class-slots class-slots)) - (owrapper (when (class-finalized-p class) - (class-wrapper class))) - (olayout (when owrapper - (wrapper-instance-slots-layout owrapper))) - (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) - (nwrapper - (cond ((null owrapper) - (make-wrapper nslots class)) - ((and (equal nlayout olayout) - (not + (sort instance-slots #'< + :key #'slot-definition-location))) + (nslots (length nlayout)) + (nwrapper-class-slots (compute-class-slots class-slots)) + (owrapper (when (class-finalized-p class) + (class-wrapper class))) + (olayout (when owrapper + (wrapper-instance-slots-layout owrapper))) + (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) + (nwrapper + (cond ((null owrapper) + (make-wrapper nslots class)) + ((and (equal nlayout olayout) + (not (loop for o in owrapper-class-slots for n in nwrapper-class-slots do (unless (eq (car o) (car n)) (return t))))) - owrapper) - (t - ;; This will initialize the new wrapper to have the - ;; same state as the old wrapper. We will then have - ;; to change that. This may seem like wasted work - ;; (and it is), but the spec requires that we call - ;; MAKE-INSTANCES-OBSOLETE. - (make-instances-obsolete class) - (class-wrapper class))))) + owrapper) + (t + ;; This will initialize the new wrapper to have the + ;; same state as the old wrapper. We will then have + ;; to change that. This may seem like wasted work + ;; (and it is), but the spec requires that we call + ;; MAKE-INSTANCES-OBSOLETE. + (make-instances-obsolete class) + (class-wrapper class))))) (with-slots (wrapper slots) class - (update-lisp-class-layout class nwrapper) - (setf slots eslotds - (wrapper-instance-slots-layout nwrapper) nlayout - (wrapper-class-slots nwrapper) nwrapper-class-slots - (wrapper-no-of-instance-slots nwrapper) nslots - wrapper nwrapper)) + (update-lisp-class-layout class nwrapper) + (setf slots eslotds + (wrapper-instance-slots-layout nwrapper) nlayout + (wrapper-class-slots nwrapper) nwrapper-class-slots + (wrapper-no-of-instance-slots nwrapper) nslots + wrapper nwrapper)) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) - (update-pv-table-cache-info class) - (maybe-update-standard-class-locations class))))) + (update-pv-table-cache-info class) + (maybe-update-standard-class-locations class))))) (defun compute-class-slots (eslotds) (let (collect) @@ -909,27 +909,27 @@ (defun update-gfs-of-class (class) (when (and (class-finalized-p class) - (let ((cpl (class-precedence-list class))) - (or (member *the-class-slot-class* cpl) - (member *the-class-standard-effective-slot-definition* - cpl)))) + (let ((cpl (class-precedence-list class))) + (or (member *the-class-slot-class* cpl) + (member *the-class-standard-effective-slot-definition* + cpl)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) - (dolist (gf (specializer-direct-generic-functions class)) - (setf (gethash gf gf-table) t)) - (mapc #'collect-gfs (class-direct-superclasses class)))) - (collect-gfs class) - (maphash (lambda (gf ignore) - (declare (ignore ignore)) - (update-gf-dfun class gf)) - gf-table))))) + (dolist (gf (specializer-direct-generic-functions class)) + (setf (gethash gf gf-table) t)) + (mapc #'collect-gfs (class-direct-superclasses class)))) + (collect-gfs class) + (maphash (lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) + gf-table))))) (defun update-initargs (class inits) (setf (plist-value class 'default-initargs) inits)) (defmethod compute-default-initargs ((class slot-class)) (let ((initargs (loop for c in (class-precedence-list class) - append (class-direct-default-initargs c)))) + append (class-direct-default-initargs c)))) (delete-duplicates initargs :test #'eq :key #'car :from-end t))) ;;;; protocols for constructing direct and effective slot definitions @@ -960,54 +960,54 @@ (let ((name-dslotds-alist ())) (dolist (c (reverse (class-precedence-list class))) (dolist (slot (class-direct-slots c)) - (let* ((name (slot-definition-name slot)) - (entry (assq name name-dslotds-alist))) - (if entry - (push slot (cdr entry)) - (push (list name slot) name-dslotds-alist))))) + (let* ((name (slot-definition-name slot)) + (entry (assq name name-dslotds-alist))) + (if entry + (push slot (cdr entry)) + (push (list name slot) name-dslotds-alist))))) (mapcar (lambda (direct) - (compute-effective-slot-definition class - (car direct) - (cdr direct))) - (nreverse name-dslotds-alist)))) + (compute-effective-slot-definition class + (car direct) + (cdr direct))) + (nreverse name-dslotds-alist)))) (defmethod compute-slots ((class standard-class)) (call-next-method)) (defmethod compute-slots :around ((class standard-class)) (let ((eslotds (call-next-method)) - (location -1)) + (location -1)) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) - (case (slot-definition-allocation eslotd) - (:instance - (incf location)) - (:class - (let* ((name (slot-definition-name eslotd)) - (from-class - (or - (slot-definition-allocation-class eslotd) - ;; we get here if the user adds an extra slot - ;; himself... - (setf (slot-definition-allocation-class eslotd) - class))) - ;; which raises the question of what we should - ;; do if we find that said user has added a slot - ;; with the same name as another slot... - (cell (or (assq name (class-slot-cells from-class)) - (setf (class-slot-cells from-class) - (cons (cons name +slot-unbound+) - (class-slot-cells from-class)))))) - (aver (consp cell)) - (if (eq +slot-unbound+ (cdr cell)) - ;; We may have inherited an initfunction - (let ((initfun (slot-definition-initfunction eslotd))) - (if initfun - (rplacd cell (funcall initfun)) - cell)) - cell))))) + (case (slot-definition-allocation eslotd) + (:instance + (incf location)) + (:class + (let* ((name (slot-definition-name eslotd)) + (from-class + (or + (slot-definition-allocation-class eslotd) + ;; we get here if the user adds an extra slot + ;; himself... + (setf (slot-definition-allocation-class eslotd) + class))) + ;; which raises the question of what we should + ;; do if we find that said user has added a slot + ;; with the same name as another slot... + (cell (or (assq name (class-slot-cells from-class)) + (setf (class-slot-cells from-class) + (cons (cons name +slot-unbound+) + (class-slot-cells from-class)))))) + (aver (consp cell)) + (if (eq +slot-unbound+ (cdr cell)) + ;; We may have inherited an initfunction + (let ((initfun (slot-definition-initfunction eslotd))) + (if initfun + (rplacd cell (funcall initfun)) + cell)) + cell))))) (unless (slot-definition-class eslotd) - (setf (slot-definition-class eslotd) class)) + (setf (slot-definition-class eslotd) class)) (initialize-internal-slot-functions eslotd)))) (defmethod compute-slots ((class funcallable-standard-class)) @@ -1015,58 +1015,58 @@ (defmethod compute-slots :around ((class funcallable-standard-class)) (labels ((instance-slot-names (slotds) - (let (collect) - (dolist (slotd slotds (nreverse collect)) - (when (eq (slot-definition-allocation slotd) :instance) - (push (slot-definition-name slotd) collect))))) - ;; This sorts slots so that slots of classes later in the CPL + (let (collect) + (dolist (slotd slotds (nreverse collect)) + (when (eq (slot-definition-allocation slotd) :instance) + (push (slot-definition-name slotd) collect))))) + ;; This sorts slots so that slots of classes later in the CPL ;; come before slots of other classes. This is crucial for ;; funcallable instances because it ensures that the slots of ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as ;; a funcallable instance. - (compute-layout (eslotds) - (let ((first ()) - (names (instance-slot-names eslotds))) - (dolist (class - (reverse (class-precedence-list class)) - (nreverse (nconc names first))) - (dolist (ss (class-slots class)) - (let ((name (slot-definition-name ss))) - (when (member name names) - (push name first) - (setq names (delete name names))))))))) + (compute-layout (eslotds) + (let ((first ()) + (names (instance-slot-names eslotds))) + (dolist (class + (reverse (class-precedence-list class)) + (nreverse (nconc names first))) + (dolist (ss (class-slots class)) + (let ((name (slot-definition-name ss))) + (when (member name names) + (push name first) + (setq names (delete name names))))))))) (let ((all-slotds (call-next-method)) - (instance-slots ()) - (class-slots ())) + (instance-slots ()) + (class-slots ())) (dolist (slotd all-slotds) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slots)) - (:class (push slotd class-slots)))) + (case (slot-definition-allocation slotd) + (:instance (push slotd instance-slots)) + (:class (push slotd class-slots)))) (let ((layout (compute-layout instance-slots))) - (dolist (slotd instance-slots) - (setf (slot-definition-location slotd) - (position (slot-definition-name slotd) layout)) - (initialize-internal-slot-functions slotd))) + (dolist (slotd instance-slots) + (setf (slot-definition-location slotd) + (position (slot-definition-name slotd) layout)) + (initialize-internal-slot-functions slotd))) (dolist (slotd class-slots) - (let ((name (slot-definition-name slotd)) - (from-class (slot-definition-allocation-class slotd))) - (setf (slot-definition-location slotd) - (assoc name (class-slot-cells from-class))) - (aver (consp (slot-definition-location slotd))) - (initialize-internal-slot-functions slotd))) + (let ((name (slot-definition-name slotd)) + (from-class (slot-definition-allocation-class slotd))) + (setf (slot-definition-location slotd) + (assoc name (class-slot-cells from-class))) + (aver (consp (slot-definition-location slotd))) + (initialize-internal-slot-functions slotd))) all-slotds))) (defmethod compute-slots ((class structure-class)) (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class - (slot-definition-name dslotd) - (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class + (slot-definition-name dslotd) + (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class 'class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) @@ -1076,7 +1076,7 @@ (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) (declare (ignore name)) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (apply #'effective-slot-definition-class class initargs))) + (class (apply #'effective-slot-definition-class class initargs))) (apply #'make-instance class initargs))) (defmethod effective-slot-definition-class ((class std-class) &rest initargs) @@ -1090,54 +1090,54 @@ (defmethod compute-effective-slot-definition-initargs ((class slot-class) direct-slotds) (let* ((name nil) - (initfunction nil) - (initform nil) - (initargs nil) - (allocation nil) - (allocation-class nil) - (type t) - (namep nil) - (initp nil) - (allocp nil)) + (initfunction nil) + (initform nil) + (initargs nil) + (allocation nil) + (allocation-class nil) + (type t) + (namep nil) + (initp nil) + (allocp nil)) (dolist (slotd direct-slotds) (when slotd - (unless namep - (setq name (slot-definition-name slotd) - namep t)) - (unless initp - (when (slot-definition-initfunction slotd) - (setq initform (slot-definition-initform slotd) - initfunction (slot-definition-initfunction slotd) - initp t))) - (unless allocp - (setq allocation (slot-definition-allocation slotd) - allocation-class (slot-definition-class slotd) - allocp t)) - (setq initargs (append (slot-definition-initargs slotd) initargs)) - (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type t) slotd-type) - ((*subtypep type slotd-type) type) - (t `(and ,type ,slotd-type))))))) + (unless namep + (setq name (slot-definition-name slotd) + namep t)) + (unless initp + (when (slot-definition-initfunction slotd) + (setq initform (slot-definition-initform slotd) + initfunction (slot-definition-initfunction slotd) + initp t))) + (unless allocp + (setq allocation (slot-definition-allocation slotd) + allocation-class (slot-definition-class slotd) + allocp t)) + (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((slotd-type (slot-definition-type slotd))) + (setq type (cond ((eq type t) slotd-type) + ((*subtypep type slotd-type) type) + (t `(and ,type ,slotd-type))))))) (list :name name - :initform initform - :initfunction initfunction - :initargs initargs - :allocation allocation - :allocation-class allocation-class - :type type - :class class))) + :initform initform + :initfunction initfunction + :initargs initargs + :allocation allocation + :allocation-class allocation-class + :type type + :class class))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) (let ((slotd (car direct-slotds))) (list* :defstruct-accessor-symbol - (slot-definition-defstruct-accessor-symbol slotd) - :internal-reader-function - (slot-definition-internal-reader-function slotd) - :internal-writer-function - (slot-definition-internal-writer-function slotd) - (call-next-method)))) + (slot-definition-defstruct-accessor-symbol slotd) + :internal-reader-function + (slot-definition-internal-reader-function slotd) + :internal-writer-function + (slot-definition-internal-writer-function slotd) + (call-next-method)))) ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE ;;; to make the method object. They have to use make-a-method which @@ -1148,13 +1148,13 @@ (defmethod add-reader-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-reader-method - () - (list (or (class-name class) 'object)) - (list class) - (make-reader-method-function class slot-name) - "automatically generated reader method" - slot-name))) + (make-a-method 'standard-reader-method + () + (list (or (class-name class) 'object)) + (list class) + (make-reader-method-function class slot-name) + "automatically generated reader method" + slot-name))) (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) @@ -1162,23 +1162,23 @@ (defmethod add-writer-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-writer-method - () - (list 'new-value (or (class-name class) 'object)) - (list *the-class-t* class) - (make-writer-method-function class slot-name) - "automatically generated writer method" - slot-name))) + (make-a-method 'standard-writer-method + () + (list 'new-value (or (class-name class) 'object)) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + "automatically generated writer method" + slot-name))) (defmethod add-boundp-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-boundp-method - () - (list (or (class-name class) 'object)) - (list class) - (make-boundp-method-function class slot-name) - "automatically generated boundp method" - slot-name))) + (make-a-method 'standard-boundp-method + () + (list (or (class-name class) 'object)) + (list class) + (make-boundp-method-function class slot-name) + "automatically generated boundp method" + slot-name))) (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) @@ -1186,7 +1186,7 @@ (defmethod remove-writer-method ((class slot-class) generic-function) (let ((method - (get-method generic-function () (list *the-class-t* class) nil))) + (get-method generic-function () (list *the-class-t* class) nil))) (when method (remove-method generic-function method)))) (defmethod remove-boundp-method ((class slot-class) generic-function) @@ -1225,7 +1225,7 @@ (defmethod validate-superclass ((class standard-class) (new-super std-class)) (let ((new-super-meta-class (class-of new-super))) (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of class) new-super-meta-class)))) + (eq (class-of class) new-super-meta-class)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it @@ -1254,28 +1254,28 @@ ;; particular, we must be sure we never change an OBSOLETE into a ;; FLUSH since OBSOLETE means do what FLUSH does and then some. (when (or (not (invalid-wrapper-p owrapper)) - ;; KLUDGE: despite the observations above, this remains - ;; a violation of locality or what might be considered - ;; good style. There has to be a better way! -- CSR, - ;; 2002-10-29 - (eq (layout-invalid owrapper) t)) + ;; KLUDGE: despite the observations above, this remains + ;; a violation of locality or what might be considered + ;; good style. There has to be a better way! -- CSR, + ;; 2002-10-29 + (eq (layout-invalid owrapper) t)) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - ;; Use :OBSOLETE instead of :FLUSH if any superclass has - ;; been obsoleted. - (if (find-if (lambda (x) - (and (consp x) (eq :obsolete (car x)))) - (layout-inherits owrapper) - :key #'layout-invalid) - (invalidate-wrapper owrapper :obsolete nwrapper) - (invalidate-wrapper owrapper :flush nwrapper))))))) + class))) + (setf (wrapper-instance-slots-layout nwrapper) + (wrapper-instance-slots-layout owrapper)) + (setf (wrapper-class-slots nwrapper) + (wrapper-class-slots owrapper)) + (with-pcl-lock + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + ;; Use :OBSOLETE instead of :FLUSH if any superclass has + ;; been obsoleted. + (if (find-if (lambda (x) + (and (consp x) (eq :obsolete (car x)))) + (layout-inherits owrapper) + :key #'layout-invalid) + (invalidate-wrapper owrapper :obsolete nwrapper) + (invalidate-wrapper owrapper :flush nwrapper))))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) @@ -1286,17 +1286,17 @@ ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. (defmethod make-instances-obsolete ((class std-class)) (let* ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) + (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + class))) (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) + (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) + (wrapper-class-slots owrapper)) (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) - class))) + (update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + (invalidate-wrapper owrapper :obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) (make-instances-obsolete (find-class class)) @@ -1340,45 +1340,45 @@ (lambda (condition stream) ;; Don't try to print the structure, since it probably won't work. (format stream - "~@" - (type-of (obsolete-structure-datum condition)))))) + "~@" + (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance) (if (not (pcl-instance-p instance)) (if *in-obsolete-instance-trap* - *the-wrapper-of-structure-object* - (let ((*in-obsolete-instance-trap* t)) - (error 'obsolete-structure :datum instance))) + *the-wrapper-of-structure-object* + (let ((*in-obsolete-instance-trap* t)) + (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) - (copy (allocate-instance class)) ;??? allocate-instance ??? - (olayout (wrapper-instance-slots-layout owrapper)) - (nlayout (wrapper-instance-slots-layout nwrapper)) - (oslots (get-slots instance)) - (nslots (get-slots copy)) - (oclass-slots (wrapper-class-slots owrapper)) - (added ()) - (discarded ()) - (plist ())) - - ;; local --> local transfer value - ;; local --> shared discard value, discard slot - ;; local --> -- discard slot - ;; shared --> local transfer value - ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) - ;; shared --> -- discard value - ;; -- --> local add slot - ;; -- --> shared -- - - ;; Collect class slots from inherited wrappers. Needed for - ;; shared -> local transfers of inherited slots. - (let ((inherited (layout-inherits owrapper))) - (loop for i from (1- (length inherited)) downto 0 - for layout = (aref inherited i) - when (typep layout 'wrapper) - do (dolist (slot (wrapper-class-slots layout)) - (pushnew slot oclass-slots :key #'car)))) - - ;; Go through all the old local slots. + (copy (allocate-instance class)) ;??? allocate-instance ??? + (olayout (wrapper-instance-slots-layout owrapper)) + (nlayout (wrapper-instance-slots-layout nwrapper)) + (oslots (get-slots instance)) + (nslots (get-slots copy)) + (oclass-slots (wrapper-class-slots owrapper)) + (added ()) + (discarded ()) + (plist ())) + + ;; local --> local transfer value + ;; local --> shared discard value, discard slot + ;; local --> -- discard slot + ;; shared --> local transfer value + ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) + ;; shared --> -- discard value + ;; -- --> local add slot + ;; -- --> shared -- + + ;; Collect class slots from inherited wrappers. Needed for + ;; shared -> local transfers of inherited slots. + (let ((inherited (layout-inherits owrapper))) + (loop for i from (1- (length inherited)) downto 0 + for layout = (aref inherited i) + when (typep layout 'wrapper) + do (dolist (slot (wrapper-class-slots layout)) + (pushnew slot oclass-slots :key #'car)))) + + ;; Go through all the old local slots. (let ((opos 0)) (dolist (name olayout) (let ((npos (posq name nlayout))) @@ -1391,38 +1391,38 @@ (setf (getf plist name) (clos-slots-ref oslots opos)))))) (incf opos))) - ;; Go through all the old shared slots. + ;; Go through all the old shared slots. (dolist (oclass-slot-and-val oclass-slots) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (when npos - (setf (clos-slots-ref nslots npos) val))))) - - ;; Go through all the new local slots to compute the added slots. - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) - - (swap-wrappers-and-slots instance copy) - - (update-instance-for-redefined-class instance - added - discarded - plist) - nwrapper))) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (posq name nlayout))) + (when npos + (setf (clos-slots-ref nslots npos) val))))) + + ;; Go through all the new local slots to compute the added slots. + (dolist (nlocal nlayout) + (unless (or (memq nlocal olayout) + (assq nlocal oclass-slots)) + (push nlocal added))) + + (swap-wrappers-and-slots instance copy) + + (update-instance-for-redefined-class instance + added + discarded + plist) + nwrapper))) (defun change-class-internal (instance new-class initargs) (let* ((old-class (class-of instance)) - (copy (allocate-instance new-class)) - (new-wrapper (get-wrapper copy)) - (old-wrapper (class-wrapper old-class)) - (old-layout (wrapper-instance-slots-layout old-wrapper)) - (new-layout (wrapper-instance-slots-layout new-wrapper)) - (old-slots (get-slots instance)) - (new-slots (get-slots copy)) - (old-class-slots (wrapper-class-slots old-wrapper))) + (copy (allocate-instance new-class)) + (new-wrapper (get-wrapper copy)) + (old-wrapper (class-wrapper old-class)) + (old-layout (wrapper-instance-slots-layout old-wrapper)) + (new-layout (wrapper-instance-slots-layout new-wrapper)) + (old-slots (get-slots instance)) + (new-slots (get-slots copy)) + (old-class-slots (wrapper-class-slots old-wrapper))) ;; "The values of local slots specified by both the class CTO and ;; CFROM are retained. If such a local slot was unbound, it @@ -1433,14 +1433,14 @@ (when old-position (setf (clos-slots-ref new-slots new-position) (clos-slots-ref old-slots old-position)))) - (incf new-position))) + (incf new-position))) ;; "The values of slots specified as shared in the class CFROM and ;; as local in the class CTO are retained." (dolist (slot-and-val old-class-slots) (let ((position (posq (car slot-and-val) new-layout))) - (when position - (setf (clos-slots-ref new-slots position) (cdr slot-and-val))))) + (when position + (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. @@ -1450,30 +1450,30 @@ instance)) (defmethod change-class ((instance standard-object) - (new-class standard-class) - &rest initargs) + (new-class standard-class) + &rest initargs) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) - (new-class funcallable-standard-class) - &rest initargs) + (new-class funcallable-standard-class) + &rest initargs) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance standard-object) - (new-class funcallable-standard-class) - &rest initargs) + (new-class funcallable-standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'standard-class)) (defmethod change-class ((instance funcallable-standard-object) - (new-class standard-class) - &rest initargs) + (new-class standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'funcallable-standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'funcallable-standard-class)) (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) (apply #'change-class instance (find-class new-class-name) initargs)) @@ -1488,14 +1488,14 @@ ;;;; definitions appear here. (defmethod shared-initialize :before - ((class built-in-class) slot-names &rest initargs) + ((class built-in-class) slot-names &rest initargs) (declare (ignore slot-names initargs)) (error "attempt to initialize or reinitialize a built in class")) -(defmethod class-direct-slots ((class built-in-class)) ()) -(defmethod class-slots ((class built-in-class)) ()) +(defmethod class-direct-slots ((class built-in-class)) ()) +(defmethod class-slots ((class built-in-class)) ()) (defmethod class-direct-default-initargs ((class built-in-class)) ()) -(defmethod class-default-initargs ((class built-in-class)) ()) +(defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) (or (eq s *the-class-t*) (eq s *the-class-stream*) @@ -1517,7 +1517,7 @@ (def class-slots)) (defmethod validate-superclass ((c slot-class) - (f forward-referenced-class)) + (f forward-referenced-class)) t) (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) @@ -1525,7 +1525,7 @@ (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) (setf (plist-value metaobject 'dependents) - (delete dependent (plist-value metaobject 'dependents)))) + (delete dependent (plist-value metaobject 'dependents)))) (defmethod map-dependents ((metaobject dependent-update-mixin) function) (dolist (dependent (plist-value metaobject 'dependents)) diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index d147a59..6cd2be2 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -19,73 +19,73 @@ (defvar str (make-instance 'str)) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'plist 10000)) + '(time-slot-value m 'plist 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" - '(time-slot-value m 'generic-function 10000)) + '(time-slot-value m 'generic-function 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" - '(time-slot-value str 'slot 10000)) + '(time-slot-value str 'slot 10000)) *tests*) (defun time-slot-value (object slot-name n) (time (dotimes-fixnum (i n) (slot-value object slot-name)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)" - '(time-slot-value-function m 10000)) + '(time-slot-value-function m 10000)) *tests*) (defun time-slot-value-function (object n) (time (dotimes-fixnum (i n) (slot-value object 'function)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" - '(time-slot-value-slot str 10000)) + '(time-slot-value-slot str 10000)) *tests*) (defun time-slot-value-slot (object n) (time (dotimes-fixnum (i n) (slot-value object 'slot)))) (push (cons "Time one-class dfun." - '(time-generic-function-methods gf 10000)) + '(time-generic-function-methods gf 10000)) *tests*) (defun time-generic-function-methods (object n) (time (dotimes-fixnum (i n) (generic-function-methods object)))) (push (cons "Time one-index dfun." - '(time-class-precedence-list c 10000)) + '(time-class-precedence-list c 10000)) *tests*) (defun time-class-precedence-list (object n) (time (dotimes-fixnum (i n) (class-precedence-list object)))) (push (cons "Time n-n dfun." - '(time-method-function m 10000)) + '(time-method-function m 10000)) *tests*) (defun time-method-function (object n) (time (dotimes-fixnum (i n) (method-function object)))) (push (cons "Time caching dfun." - '(time-class-slots c 10000)) + '(time-class-slots c 10000)) *tests*) (defun time-class-slots (object n) (time (dotimes-fixnum (i n) (class-slots object)))) (push (cons "Time typep for classes." - '(time-typep-standard-object m 10000)) + '(time-typep-standard-object m 10000)) *tests*) (defun time-typep-standard-object (object n) (time (dotimes-fixnum (i n) (typep object 'standard-object)))) (push (cons "Time default-initargs." - '(time-default-initargs (find-class 'plist-mixin) 1000)) + '(time-default-initargs (find-class 'plist-mixin) 1000)) *tests*) (defun time-default-initargs (class n) (time (dotimes-fixnum (i n) (default-initargs class nil)))) (push (cons "Time make-instance." - '(time-make-instance (find-class 'plist-mixin) 1000)) + '(time-make-instance (find-class 'plist-mixin) 1000)) *tests*) (defun time-make-instance (class n) (time (dotimes-fixnum (i n) (make-instance class)))) (push (cons "Time constant-keys make-instance." - '(time-constant-keys-make-instance 1000)) + '(time-constant-keys-make-instance 1000)) *tests*) (expanding-make-instance-toplevel @@ -99,41 +99,41 @@ (defun expand-all-macros (form) (walk-form form nil (lambda (form context env) - (if (and (eq context :eval) - (consp form) - (symbolp (car form)) - (not (special-form-p (car form))) - (macro-function (car form))) - (values (macroexpand form env)) - form)))) + (if (and (eq context :eval) + (consp form) + (symbolp (car form)) + (not (special-form-p (car form))) + (macro-function (car form))) + (values (macroexpand form env)) + form)))) (push (cons "Macroexpand meth-structure-slot-value" - '(pprint (multiple-value-bind (pgf pm) - (prototypes-for-make-method-lambda - 'meth-structure-slot-value) - (expand-defmethod - 'meth-structure-slot-value pgf pm - nil '((object str)) - '((lambda () (slot-value object 'slot))) - nil)))) + '(pprint (multiple-value-bind (pgf pm) + (prototypes-for-make-method-lambda + 'meth-structure-slot-value) + (expand-defmethod + 'meth-structure-slot-value pgf pm + nil '((object str)) + '((lambda () (slot-value object 'slot))) + nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." - '(disassemble (meth-structure-slot-value str))) + '(disassemble (meth-structure-slot-value str))) *tests*) (defmethod meth-structure-slot-value ((object str)) (lambda () (slot-value object 'slot))) #|| ; interesting, but long. (produces 100 lines of output) (push (cons "Macroexpand meth-standard-slot-value" - '(pprint (expand-all-macros - (expand-defmethod-internal 'meth-standard-slot-value - nil '((object standard-method)) - '((lambda () (slot-value object 'function))) - nil)))) + '(pprint (expand-all-macros + (expand-defmethod-internal 'meth-standard-slot-value + nil '((object standard-method)) + '((lambda () (slot-value object 'function))) + nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." - '(disassemble (meth-standard-slot-value m))) + '(disassemble (meth-standard-slot-value m))) *tests*) (defmethod meth-standard-slot-value ((object standard-method)) (lambda () (slot-value object 'function))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 231ca8d..7c307f0 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -30,16 +30,16 @@ (declare (fixnum pos)) (block loop (dolist (sn (wrapper-instance-slots-layout ,wrapper)) - (when (eq ,slot-name sn) (return-from loop pos)) - (incf pos))))) + (when (eq ,slot-name sn) (return-from loop pos)) + (incf pos))))) (defun pv-cache-limit-fn (nlines) (default-limit-fn nlines)) (defstruct (pv-table (:predicate pv-tablep) - (:constructor make-pv-table-internal - (slot-name-lists call-list)) - (:copier nil)) + (:constructor make-pv-table-internal + (slot-name-lists call-list)) + (:copier nil)) (cache nil :type (or cache null)) (pv-size 0 :type fixnum) (slot-name-lists nil :type list) @@ -69,63 +69,63 @@ (defun intern-pv-table (&key slot-name-lists call-list) (let ((new-p nil)) (flet ((inner (x) - (or (gethash x *slot-name-lists-inner*) - (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) - (outer (x) - (or (gethash x *slot-name-lists-outer*) - (setf (gethash x *slot-name-lists-outer*) - (let ((snl (copy-list (cdr x))) - (cl (car x))) - (setq new-p t) - (make-pv-table :slot-name-lists snl - :call-list cl)))))) + (or (gethash x *slot-name-lists-inner*) + (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) + (outer (x) + (or (gethash x *slot-name-lists-outer*) + (setf (gethash x *slot-name-lists-outer*) + (let ((snl (copy-list (cdr x))) + (cl (car x))) + (setq new-p t) + (make-pv-table :slot-name-lists snl + :call-list cl)))))) (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) (when new-p - (let ((pv-index 1)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (note-pv-table-reference slot-name pv-index pv-table) - (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) - (setf (pv-table-pv-size pv-table) pv-index))) + (let ((pv-index 1)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (note-pv-table-reference slot-name pv-index pv-table) + (incf pv-index))) + (dolist (gf-call call-list) + (note-pv-table-reference gf-call pv-index pv-table) + (incf pv-index)) + (setf (pv-table-pv-size pv-table) pv-index))) pv-table)))) (defun note-pv-table-reference (ref pv-offset pv-table) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (when (listp entry) (let ((table-entry (assq pv-table entry))) - (when (and (null table-entry) - (> (length entry) 8)) - (let ((new-table-table (make-hash-table :size 16 :test 'eq))) - (dolist (table-entry entry) - (setf (gethash (car table-entry) new-table-table) - (cdr table-entry))) - (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) - (when (listp entry) - (if (null table-entry) - (let ((new (cons pv-table pv-offset))) - (if (consp entry) - (push new (cdr entry)) - (setf (gethash ref *pv-key-to-pv-table-table*) - (list new)))) - (push pv-offset (cdr table-entry))) - (return-from note-pv-table-reference nil)))) + (when (and (null table-entry) + (> (length entry) 8)) + (let ((new-table-table (make-hash-table :size 16 :test 'eq))) + (dolist (table-entry entry) + (setf (gethash (car table-entry) new-table-table) + (cdr table-entry))) + (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) + (when (listp entry) + (if (null table-entry) + (let ((new (cons pv-table pv-offset))) + (if (consp entry) + (push new (cdr entry)) + (setf (gethash ref *pv-key-to-pv-table-table*) + (list new)))) + (push pv-offset (cdr table-entry))) + (return-from note-pv-table-reference nil)))) (let ((list (gethash pv-table entry))) (if (consp list) - (push pv-offset (cdr list)) - (setf (gethash pv-table entry) (list pv-offset))))) + (push pv-offset (cdr list)) + (setf (gethash pv-table entry) (list pv-offset))))) nil) (defun map-pv-table-references-of (ref function) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) (if (listp entry) - (dolist (table+pv-offset-list entry) - (funcall function - (car table+pv-offset-list) - (cdr table+pv-offset-list))) - (maphash function entry))) + (dolist (table+pv-offset-list entry) + (funcall function + (car table+pv-offset-list) + (cdr table+pv-offset-list))) + (maphash function entry))) ref) (defvar *pvs* (make-hash-table :test 'equal)) @@ -133,41 +133,41 @@ (defun optimize-slot-value-by-class-p (class slot-name type) (or (not (eq *boot-state* 'complete)) (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (slot-accessor-std-p slotd type))))) + (and slotd + (slot-accessor-std-p slotd type))))) (defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) (if (symbolp slot-name) (when (optimize-slot-value-by-class-p class slot-name 'all) - (or (instance-slot-index wrapper slot-name) - (let ((cell (assq slot-name class-slots))) - (when cell - (setf (car class-slot-p-cell) t) - cell)))) + (or (instance-slot-index wrapper slot-name) + (let ((cell (assq slot-name class-slots))) + (when cell + (setf (car class-slot-p-cell) t) + cell)))) (when (consp slot-name) - (dolist (type '(reader writer) nil) - (when (eq (car slot-name) type) - (return - (let* ((gf-name (cadr slot-name)) - (gf (gdefinition gf-name)) - (location (when (eq *boot-state* 'complete) - (accessor-values1 gf type class)))) - (when (consp location) - (setf (car class-slot-p-cell) t)) - location))))))) + (dolist (type '(reader writer) nil) + (when (eq (car slot-name) type) + (return + (let* ((gf-name (cadr slot-name)) + (gf (gdefinition gf-name)) + (location (when (eq *boot-state* 'complete) + (accessor-values1 gf type class)))) + (when (consp location) + (setf (car class-slot-p-cell) t)) + location))))))) (defun compute-pv (slot-name-lists wrappers) (unless (listp wrappers) (setq wrappers (list wrappers))) (let* ((not-simple-p-cell (list nil)) - (elements + (elements (let ((elements nil)) (dolist (slot-names slot-name-lists) - (when slot-names - (let* ((wrapper (pop wrappers)) - (std-p (typep wrapper 'wrapper)) - (class (wrapper-class* wrapper)) - (class-slots (and std-p (wrapper-class-slots wrapper)))) - (dolist (slot-name (cdr slot-names)) + (when slot-names + (let* ((wrapper (pop wrappers)) + (std-p (typep wrapper 'wrapper)) + (class (wrapper-class* wrapper)) + (class-slots (and std-p (wrapper-class-slots wrapper)))) + (dolist (slot-name (cdr slot-names)) ;; Original PCL code had this idiom. why not: ;; ;; (WHEN STD-P @@ -178,17 +178,17 @@ elements))))) (nreverse elements)))) (if (car not-simple-p-cell) - (make-permutation-vector (cons t elements)) - (or (gethash elements *pvs*) - (setf (gethash elements *pvs*) - (make-permutation-vector (cons nil elements))))))) + (make-permutation-vector (cons t elements)) + (or (gethash elements *pvs*) + (setf (gethash elements *pvs*) + (make-permutation-vector (cons nil elements))))))) (defun compute-calls (call-list wrappers) (declare (ignore call-list wrappers)) #|| (map 'vector (lambda (call) - (compute-emf-from-wrappers call wrappers)) + (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) @@ -198,19 +198,19 @@ (when call (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) - (error "should not get here") ; there is another mechanism for this. - (lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) + (error "should not get here") ; there is another mechanism for this. + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -218,22 +218,22 @@ (defun pv-table-lookup (pv-table pv-wrappers) (let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) - (call-list (pv-table-call-list pv-table)) - (cache (or (pv-table-cache pv-table) - (setf (pv-table-cache pv-table) - (get-cache (- (length slot-name-lists) - (count nil slot-name-lists)) - t - #'pv-cache-limit-fn - 2))))) + (call-list (pv-table-call-list pv-table)) + (cache (or (pv-table-cache pv-table) + (setf (pv-table-cache pv-table) + (get-cache (- (length slot-name-lists) + (count nil slot-name-lists)) + t + #'pv-cache-limit-fn + 2))))) (or (probe-cache cache pv-wrappers) - (let* ((pv (compute-pv slot-name-lists pv-wrappers)) - (calls (compute-calls call-list pv-wrappers)) - (pv-cell (cons pv calls)) - (new-cache (fill-cache cache pv-wrappers pv-cell))) - (unless (eq new-cache cache) - (setf (pv-table-cache pv-table) new-cache)) - pv-cell)))) + (let* ((pv (compute-pv slot-name-lists pv-wrappers)) + (calls (compute-calls call-list pv-wrappers)) + (pv-cell (cons pv calls)) + (new-cache (fill-cache cache pv-wrappers pv-cell))) + (unless (eq new-cache cache) + (setf (pv-table-cache pv-table) new-cache)) + pv-cell)))) (defun make-pv-type-declaration (var) `(type simple-vector ,var)) @@ -256,147 +256,147 @@ (defun update-pv-table-cache-info (class) (let ((slot-names-for-pv-table-update nil) - (new-icui nil)) + (new-icui nil)) (dolist (icu *pv-table-cache-update-info*) (if (eq (car icu) class) - (pushnew (cdr icu) slot-names-for-pv-table-update) - (push icu new-icui))) + (pushnew (cdr icu) slot-names-for-pv-table-update) + (push icu new-icui))) (setq *pv-table-cache-update-info* new-icui) (when slot-names-for-pv-table-update (update-all-pv-table-caches class slot-names-for-pv-table-update)))) (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) - (std-p (typep cwrapper 'wrapper)) - (class-slots (and std-p (wrapper-class-slots cwrapper))) - (class-slot-p-cell (list nil)) - (new-values (mapcar (lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) - slot-names)) - (pv-tables nil)) + (std-p (typep cwrapper 'wrapper)) + (class-slots (and std-p (wrapper-class-slots cwrapper))) + (class-slot-p-cell (list nil)) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) + slot-names)) + (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name (lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) - (slot-name-lists (pv-table-slot-name-lists pv-table)) - (pv-size (pv-table-pv-size pv-table)) - (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 1) (param-index 0)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (let ((a (assoc slot-name new-values))) - (setf (svref pv-map map-index) - (and a (cons param-index (cdr a))))) - (incf map-index)) - (incf param-index))) - (when cache - (map-cache (lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) - cache)))))) + (slot-name-lists (pv-table-slot-name-lists pv-table)) + (pv-size (pv-table-pv-size pv-table)) + (pv-map (make-array pv-size :initial-element nil))) + (let ((map-index 1) (param-index 0)) + (dolist (slot-name-list slot-name-lists) + (dolist (slot-name (cdr slot-name-list)) + (let ((a (assoc slot-name new-values))) + (setf (svref pv-map map-index) + (and a (cons param-index (cdr a))))) + (incf map-index)) + (incf param-index))) + (when cache + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) + cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) (if (not (if (atom wrappers) - (eq cwrapper wrappers) - (dolist (wrapper wrappers nil) - (when (eq wrapper cwrapper) - (return t))))) + (eq cwrapper wrappers) + (dolist (wrapper wrappers nil) + (when (eq wrapper cwrapper) + (return t))))) pv (let* ((old-intern-p (listp (pvref pv 0))) - (new-pv (if old-intern-p - (copy-pv pv) - pv)) - (new-intern-p t)) - (if (atom wrappers) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if map - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil))) - (let ((param 0)) - (dolist (wrapper wrappers) - (when (eq wrapper cwrapper) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if (and map (= (car map) param)) - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil)))) - (incf param)))) - (when new-intern-p - (setq new-pv (let ((list-pv (coerce pv 'list))) - (or (gethash (cdr list-pv) *pvs*) - (setf (gethash (cdr list-pv) *pvs*) - (if old-intern-p - new-pv - (make-permutation-vector list-pv))))))) - new-pv))) + (new-pv (if old-intern-p + (copy-pv pv) + pv)) + (new-intern-p t)) + (if (atom wrappers) + (dotimes-fixnum (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if map + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil))) + (let ((param 0)) + (dolist (wrapper wrappers) + (when (eq wrapper cwrapper) + (dotimes-fixnum (i pv-size) + (when (consp (let ((map (svref pv-map i))) + (if (and map (= (car map) param)) + (setf (pvref new-pv i) (cdr map)) + (pvref new-pv i)))) + (setq new-intern-p nil)))) + (incf param)))) + (when new-intern-p + (setq new-pv (let ((list-pv (coerce pv 'list))) + (or (gethash (cdr list-pv) *pvs*) + (setf (gethash (cdr list-pv) *pvs*) + (if old-intern-p + new-pv + (make-permutation-vector list-pv))))))) + new-pv))) (defun maybe-expand-accessor-form (form required-parameters slots env) (let* ((fname (car form)) - #||(len (length form))||# - (gf (if (symbolp fname) - (unencapsulated-fdefinition fname) - (gdefinition fname)))) + #||(len (length form))||# + (gf (if (symbolp fname) + (unencapsulated-fdefinition fname) + (gdefinition fname)))) (macrolet ((maybe-optimize-reader () - `(let ((parameter - (can-optimize-access1 (cadr form) - required-parameters env))) - (when parameter - (optimize-reader slots parameter gf-name form)))) - (maybe-optimize-writer () - `(let ((parameter - (can-optimize-access1 (caddr form) - required-parameters env))) - (when parameter - (optimize-writer slots parameter gf-name form))))) + `(let ((parameter + (can-optimize-access1 (cadr form) + required-parameters env))) + (when parameter + (optimize-reader slots parameter gf-name form)))) + (maybe-optimize-writer () + `(let ((parameter + (can-optimize-access1 (caddr form) + required-parameters env))) + (when parameter + (optimize-writer slots parameter gf-name form))))) (unless (and (consp (cadr form)) - (eq 'instance-accessor-parameter (caadr form))) - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer))))))))))))) + (eq 'instance-accessor-parameter (caadr form))) + (when (and (eq *boot-state* 'complete) + (generic-function-p gf)) + (let ((methods (generic-function-methods gf))) + (when methods + (let* ((gf-name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (nreq (length metatypes)) + (applyp (arg-info-applyp arg-info))) + (when (null applyp) + (cond ((= nreq 1) + (when (some #'standard-reader-method-p methods) + (maybe-optimize-reader))) + ((and (= nreq 2) + (consp gf-name) + (eq (car gf-name) 'setf)) + (when (some #'standard-writer-method-p methods) + (maybe-optimize-writer))))))))))))) (defun optimize-generic-function-call (form - required-parameters - env - slots - calls) + required-parameters + env + slots + calls) (declare (ignore required-parameters env slots calls)) (or ; (optimize-reader ...)? form)) (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) - (slot-value 'reader) - (set-slot-value 'writer) - (slot-boundp 'boundp))) - (var (cadr form)) - (slot-name (eval (caddr form)))) ; known to be constant + (slot-value 'reader) + (set-slot-value 'writer) + (slot-boundp 'boundp))) + (var (cadr form)) + (slot-name (eval (caddr form)))) ; known to be constant (can-optimize-access1 var required-parameters env type slot-name))) ;;; FIXME: This looks like an internal helper function for @@ -406,7 +406,7 @@ ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword ;;; args instead of optional ones, too. (defun can-optimize-access1 (var required-parameters env - &optional type slot-name) + &optional type slot-name) (when (and (consp var) (eq 'the (car var))) ;; FIXME: We should assert list of length 3 here. Or maybe we ;; should just define EXTRACT-THE, replace the whole @@ -419,71 +419,71 @@ (setq var (caddr var))) (when (symbolp var) (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) - (parameter-or-nil (car (memq (or rebound? var) - required-parameters)))) + (parameter-or-nil (car (memq (or rebound? var) + required-parameters)))) (when parameter-or-nil - (let* ((class-name (caddr (var-declaration '%class - parameter-or-nil - env))) - (class (find-class class-name nil))) - (when (or (not (eq *boot-state* 'complete)) - (and class (not (class-finalized-p class)))) - (setq class nil)) - (when (and class-name (not (eq class-name t))) - (when (or (null type) - (not (and class - (memq *the-class-structure-object* - (class-precedence-list class)))) - (optimize-slot-value-by-class-p class slot-name type)) - (cons parameter-or-nil (or class class-name))))))))) + (let* ((class-name (caddr (var-declaration '%class + parameter-or-nil + env))) + (class (find-class class-name nil))) + (when (or (not (eq *boot-state* 'complete)) + (and class (not (class-finalized-p class)))) + (setq class nil)) + (when (and class-name (not (eq class-name t))) + (when (or (null type) + (not (and class + (memq *the-class-structure-object* + (class-precedence-list class)))) + (optimize-slot-value-by-class-p class slot-name type)) + (cons parameter-or-nil (or class class-name))))))))) (defun optimize-slot-value (slots sparameter form) (if sparameter (destructuring-bind (ignore1 ignore2 slot-name-form) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :read sparameter slot-name nil))) + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots :read sparameter slot-name nil))) `(accessor-slot-value ,@(cdr form)))) (defun optimize-set-slot-value (slots sparameter form) (if sparameter (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :write - sparameter - slot-name - new-value))) + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :write + sparameter + slot-name + new-value))) `(accessor-set-slot-value ,@(cdr form)))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a - ;; fourth element in it, NEW-VALUE. It's hard to see how - ;; that could possibly be right, since SLOT-BOUNDP has no - ;; NEW-VALUE. Since it was causing a failure in building PCL - ;; for SBCL, so I changed it to match the definition of - ;; SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded - ;; out by this, since this is old code which has worked for - ;; ages to build PCL for CMU CL, so it's hard to see why it - ;; should need a patch like this in order to build PCL for - ;; SBCL. I'd like to return to this and find a test case - ;; which exercises this function both in CMU CL, to see - ;; whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, - ;; patched it wrong). - (slot-boundp-symbol instance slot-name-form) - form - (declare (ignore slot-boundp-symbol instance)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :boundp - sparameter - slot-name - nil))) + ;; FIXME: In CMU CL ca. 19991205, this binding list had a + ;; fourth element in it, NEW-VALUE. It's hard to see how + ;; that could possibly be right, since SLOT-BOUNDP has no + ;; NEW-VALUE. Since it was causing a failure in building PCL + ;; for SBCL, so I changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in the + ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded + ;; out by this, since this is old code which has worked for + ;; ages to build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build PCL for + ;; SBCL. I'd like to return to this and find a test case + ;; which exercises this function both in CMU CL, to see + ;; whether it's really a previously-unexercised bug or + ;; whether I've misunderstood something (and, presumably, + ;; patched it wrong). + (slot-boundp-symbol instance slot-name-form) + form + (declare (ignore slot-boundp-symbol instance)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :boundp + sparameter + slot-name + nil))) `(accessor-slot-boundp ,@(cdr form)))) (defun optimize-reader (slots sparameter gf-name form) @@ -494,8 +494,8 @@ (defun optimize-writer (slots sparameter gf-name form) (if sparameter (destructuring-bind (ignore1 ignore2 new-value) form - (declare (ignore ignore1 ignore2)) - (optimize-accessor-call slots :write sparameter gf-name new-value)) + (declare (ignore ignore1 ignore2)) + (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) ;;; The SLOTS argument is an alist, the CAR of each entry is the name @@ -503,57 +503,57 @@ ;;; the position of an entry in the alist corresponds to the ;;; argument's position in the lambda list. (defun optimize-instance-access (slots - read/write - sparameter - slot-name - new-value) + read/write + sparameter + slot-name + new-value) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) + (parameter (if (consp sparameter) (car sparameter) sparameter))) (if (and (eq *boot-state* 'complete) - (classp class) - (memq *the-class-structure-object* (class-precedence-list class))) - (let ((slotd (find-slot-definition class slot-name))) - (ecase read/write - (:read - `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) - (:write - `(setf (,(slot-definition-defstruct-accessor-symbol slotd) - ,parameter) - ,new-value)) - (:boundp - t))) - (let* ((parameter-entry (assq parameter slots)) - (slot-entry (assq slot-name (cdr parameter-entry))) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (bug "slot optimization bewilderment: O-I-A")) - (unless slot-entry - (setq slot-entry (list slot-name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-read ,pv-offset-form ,parameter ,position - ',slot-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-write ,pv-offset-form ,parameter ,position - ',slot-name ',class .new-value.))) - (:boundp - `(instance-boundp ,pv-offset-form ,parameter ,position - ',slot-name ',class))))))) + (classp class) + (memq *the-class-structure-object* (class-precedence-list class))) + (let ((slotd (find-slot-definition class slot-name))) + (ecase read/write + (:read + `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) + (:write + `(setf (,(slot-definition-defstruct-accessor-symbol slotd) + ,parameter) + ,new-value)) + (:boundp + t))) + (let* ((parameter-entry (assq parameter slots)) + (slot-entry (assq slot-name (cdr parameter-entry))) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless parameter-entry + (bug "slot optimization bewilderment: O-I-A")) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr parameter-entry))) + (push pv-offset-form (cdr slot-entry)) + (ecase read/write + (:read + `(instance-read ,pv-offset-form ,parameter ,position + ',slot-name ',class)) + (:write + `(let ((.new-value. ,new-value)) + (instance-write ,pv-offset-form ,parameter ,position + ',slot-name ',class .new-value.))) + (:boundp + `(instance-boundp ,pv-offset-form ,parameter ,position + ',slot-name ',class))))))) (defun optimize-accessor-call (slots read/write sparameter gf-name new-value) (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter)) - (parameter-entry (assq parameter slots)) - (name (case read/write - (:read `(reader ,gf-name)) - (:write `(writer ,gf-name)))) - (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (parameter (if (consp sparameter) (car sparameter) sparameter)) + (parameter-entry (assq parameter slots)) + (name (case read/write + (:read `(reader ,gf-name)) + (:write `(writer ,gf-name)))) + (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry (error "slot optimization bewilderment: O-A-C")) (unless slot-entry @@ -565,62 +565,62 @@ `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) (:write `(let ((.new-value. ,new-value)) - (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class - .new-value.)))))) + (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class + .new-value.)))))) (defvar *unspecific-arg* '..unspecific-arg..) (defun optimize-gf-call-internal (form slots env) (when (and (consp form) - (eq (car form) 'the)) + (eq (car form) 'the)) (setq form (caddr form))) (or (and (symbolp form) - (let* ((rebound? (caddr (var-declaration '%variable-rebinding - form - env))) - (parameter-or-nil (car (assq (or rebound? form) slots)))) - (when parameter-or-nil - (let* ((class-name (caddr (var-declaration 'class - parameter-or-nil - env)))) - (when (and class-name (not (eq class-name t))) - (position parameter-or-nil slots :key #'car)))))) + (let* ((rebound? (caddr (var-declaration '%variable-rebinding + form + env))) + (parameter-or-nil (car (assq (or rebound? form) slots)))) + (when parameter-or-nil + (let* ((class-name (caddr (var-declaration 'class + parameter-or-nil + env)))) + (when (and class-name (not (eq class-name t))) + (position parameter-or-nil slots :key #'car)))))) (if (constantp form) - (let ((form (eval form))) - (if (symbolp form) - form - *unspecific-arg*)) - *unspecific-arg*))) + (let ((form (eval form))) + (if (symbolp form) + form + *unspecific-arg*)) + *unspecific-arg*))) (defun optimize-gf-call (slots calls gf-call-form nreq restp env) (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work (let* ((args (cdr gf-call-form)) - (all-args-p (eq (car gf-call-form) 'make-instance)) - (non-required-args (nthcdr nreq args)) - (required-args (ldiff args non-required-args)) - (call-spec (list (car gf-call-form) nreq restp - (mapcar (lambda (form) - (optimize-gf-call-internal form slots env)) - (if all-args-p - args - required-args)))) - (call-entry (assoc call-spec calls :test #'equal)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (all-args-p (eq (car gf-call-form) 'make-instance)) + (non-required-args (nthcdr nreq args)) + (required-args (ldiff args non-required-args)) + (call-spec (list (car gf-call-form) nreq restp + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) + (if all-args-p + args + required-args)))) + (call-entry (assoc call-spec calls :test #'equal)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless (some #'integerp - (let ((spec-args (cdr call-spec))) - (if all-args-p - (ldiff spec-args (nthcdr nreq spec-args)) - spec-args))) - (return-from optimize-gf-call nil)) + (let ((spec-args (cdr call-spec))) + (if all-args-p + (ldiff spec-args (nthcdr nreq spec-args)) + spec-args))) + (return-from optimize-gf-call nil)) (unless call-entry - (setq call-entry (list call-spec)) - (push call-entry (cdr calls))) + (setq call-entry (list call-spec)) + (push call-entry (cdr calls))) (push pv-offset-form (cdr call-entry)) (if (eq (car call-spec) 'make-instance) - `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) - `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) - (invoke-effective-method-function .emf. ,restp - ,@required-args ,@(when restp `((list ,@non-required-args))))))))) + `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) + `(let ((.emf. (pv-ref .pv. ,pv-offset-form))) + (invoke-effective-method-function .emf. ,restp + ,@required-args ,@(when restp `((list ,@non-required-args))))))))) (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) @@ -631,29 +631,29 @@ ;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (eq :class (slot-definition-allocation slotd))))))) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class - slot-name - type)))))) + (standard-class-p class) + (not (eq class *the-class-t*)) ; shouldn't happen, though. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (skip-optimize-slot-value-by-class-p class + slot-name + type)))))) (defun skip-optimize-slot-value-by-class-p (class slot-name type) (let ((slotd (find-slot-definition class slot-name))) (and slotd - (eq *boot-state* 'complete) - (not (slot-accessor-std-p slotd type))))) + (eq *boot-state* 'complete) + (not (slot-accessor-std-p slotd type))))) (defmacro instance-read-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) @@ -661,39 +661,39 @@ (if (eq type :default) default (let* ((index (gensym)) - (value index)) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (setq ,value (typecase ,index - ;; FIXME: the line marked by KLUDGE below - ;; (and the analogous spot in - ;; INSTANCE-WRITE-INTERNAL) is there purely - ;; to suppress a type mismatch warning that - ;; propagates through to user code. - ;; Presumably SLOTS at this point can never - ;; actually be NIL, but the compiler seems - ;; to think it could, so we put this here - ;; to shut it up. (see also mail Rudi - ;; Schlatte sbcl-devel 2003-09-21) -- CSR, - ;; 2003-11-30 - ,@(when (or (null type) (eq type :instance)) - `((fixnum - (and ,slots ; KLUDGE - (clos-slots-ref ,slots ,index))))) - ,@(when (or (null type) (eq type :class)) - `((cons (cdr ,index)))) - (t +slot-unbound+))) - (if (eq ,value +slot-unbound+) - ,default - ,value)))))) + (value index)) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below + ;; (and the analogous spot in + ;; INSTANCE-WRITE-INTERNAL) is there purely + ;; to suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems + ;; to think it could, so we put this here + ;; to shut it up. (see also mail Rudi + ;; Schlatte sbcl-devel 2003-09-21) -- CSR, + ;; 2003-11-30 + ,@(when (or (null type) (eq type :instance)) + `((fixnum + (and ,slots ; KLUDGE + (clos-slots-ref ,slots ,index))))) + ,@(when (or (null type) (eq type :class)) + `((cons (cdr ,index)))) + (t +slot-unbound+))) + (if (eq ,value +slot-unbound+) + ,default + ,value)))))) (defmacro instance-read (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'reader) `(accessor-slot-value ,parameter ,slot-name) `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-value ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset (accessor-slot-value ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) @@ -703,78 +703,78 @@ :instance)) (defmacro instance-write-internal (pv slots pv-offset new-value default - &optional type) + &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) (if (eq type :default) default (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type :instance)) `((fixnum (and ,slots - (setf (clos-slots-ref ,slots ,index) - ,new-value))))) - ,@(when (or (null type) (eq type :class)) - `((cons (setf (cdr ,index) ,new-value)))) - (t ,default))))))) + (setf (clos-slots-ref ,slots ,index) + ,new-value))))) + ,@(when (or (null type) (eq type :class)) + `((cons (setf (cdr ,index) ,new-value)))) + (t ,default))))))) (defmacro instance-write (pv-offset - parameter - position - slot-name - class - new-value) + parameter + position + slot-name + class + new-value) (if (skip-fast-slot-access-p class slot-name 'writer) `(accessor-set-slot-value ,parameter ,slot-name ,new-value) `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (accessor-set-slot-value ,parameter ,slot-name ,new-value) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset ,new-value + (accessor-set-slot-value ,parameter ,slot-name ,new-value) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance)))) (defmacro instance-writer (pv-offset - parameter - position - gf-name - class - new-value) + parameter + position + gf-name + class + new-value) (declare (ignore class)) `(instance-write-internal .pv. ,(slot-vector-symbol position) ,pv-offset ,new-value (,(if (consp gf-name) - (get-setf-fun-name gf-name) - gf-name) + (get-setf-fun-name gf-name) + gf-name) (instance-accessor-parameter ,parameter) ,new-value) :instance)) (defmacro instance-boundp-internal (pv slots pv-offset default - &optional type) + &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) (if (eq type :default) default (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type :instance)) - `((fixnum (not (and ,slots + `(locally (declare #.*optimize-speed*) + (let ((,index (pvref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null type) (eq type :instance)) + `((fixnum (not (and ,slots (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type :class)) - `((cons (not (eq (cdr ,index) +slot-unbound+))))) - (t ,default))))))) + ,@(when (or (null type) (eq type :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) + (t ,default))))))) (defmacro instance-boundp (pv-offset parameter position slot-name class) (if (skip-fast-slot-access-p class slot-name 'boundp) `(accessor-slot-boundp ,parameter ,slot-name) `(instance-boundp-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance)))) ;;; This magic function has quite a job to do indeed. ;;; @@ -795,47 +795,47 @@ (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar (lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) - slots)) - (call-list - (mapcar #'car calls))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) + slots)) + (call-list + (mapcar #'car calls))) (dolist (call call-list) - (dolist (arg (cdr call)) - (when (integerp arg) - (setf (car (nth arg slot-name-lists)) t)))) + (dolist (arg (cdr call)) + (when (integerp arg) + (setf (car (nth arg slot-name-lists)) t)))) (setq slot-name-lists (mapcar (lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) - slot-name-lists)) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) + slot-name-lists)) (let ((cvt (apply #'vector - (let ((i -1)) - (mapcar (lambda (r+snl) - (when r+snl (incf i))) - slot-name-lists))))) - (setq call-list (mapcar (lambda (call) - (cons (car call) - (mapcar (lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) - call-list))) + (let ((i -1)) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) + slot-name-lists))))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) + call-list))) (values slot-name-lists call-list)))) (defun mutate-slots-and-calls (slots calls) (let ((sorted-slots (sort-slots slots)) - (sorted-calls (sort-calls (cdr calls))) - (pv-offset 0)) ; index 0 is for info + (sorted-calls (sort-calls (cdr calls))) + (pv-offset 0)) ; index 0 is for info (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) - (incf pv-offset) - (dolist (form (cdr slot-entry)) - (setf (cadr form) pv-offset)))) + (incf pv-offset) + (dolist (form (cdr slot-entry)) + (setf (cadr form) pv-offset)))) (dolist (call-entry sorted-calls) (incf pv-offset) (dolist (form (cdr call-entry)) - (setf (cadr form) pv-offset))) + (setf (cadr form) pv-offset))) (values sorted-slots sorted-calls))) (defun symbol-pkg-name (sym) @@ -856,30 +856,30 @@ ;;; * faster code. (defun symbol-lessp (a b) (if (eq (symbol-package a) - (symbol-package b)) + (symbol-package b)) (string-lessp (symbol-name a) - (symbol-name b)) + (symbol-name b)) (string-lessp (symbol-pkg-name a) - (symbol-pkg-name b)))) + (symbol-pkg-name b)))) (defun symbol-or-cons-lessp (a b) (etypecase a (symbol (etypecase b - (symbol (symbol-lessp a b)) - (cons t))) + (symbol (symbol-lessp a b)) + (cons t))) (cons (etypecase b - (symbol nil) - (cons (if (eq (car a) (car b)) - (symbol-or-cons-lessp (cdr a) (cdr b)) - (symbol-or-cons-lessp (car a) (car b)))))))) + (symbol nil) + (cons (if (eq (car a) (car b)) + (symbol-or-cons-lessp (cdr a) (cdr b)) + (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) (mapcar (lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) - slots)) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) + slots)) (defun sort-calls (calls) (sort calls #'symbol-or-cons-lessp :key #'car)) @@ -890,7 +890,7 @@ ;;;; stuff too. (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) - &body body) + &body body) (let (slot-vars pv-parameters) (loop for slots in slot-name-lists for required-parameter in required-parameters @@ -903,25 +903,25 @@ ,@body))) (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) + &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) + slot-vars pv-parameters)) (declare (ignorable ,@(mapcar #'identity slot-vars))) ,@body))) ;;; This gets used only when the default MAKE-METHOD-LAMBDA is ;;; overridden. (defmacro pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) + &rest forms) `(let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) (declare ,(make-pv-type-declaration pv)) (declare ,(make-calls-type-declaration calls)) ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) + `((declare (special ,pv-table-symbol)))) ,pv ,calls ,@forms)) @@ -960,68 +960,68 @@ (defun split-declarations (body args maybe-reads-params-p) (let ((inner-decls nil) - (outer-decls nil) - decl) + (outer-decls nil) + decl) (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-var-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *var-declarations-with-arg*)) - (non-arg-p - (member declaration-name - *var-declarations-without-arg*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - ;; FIXME: This warning, and perhaps the - ;; various *VAR-DECLARATIONS-FOO* and/or - ;; *NON-VAR-DECLARATIONS* variables, - ;; could probably go away now that we're not - ;; trying to be portable between different - ;; CLTL1 hosts the way PCL was. (Note that to - ;; do this right, we need to be able to handle - ;; user-defined (DECLAIM (DECLARATION FOO)) - ;; stuff.) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declaration without argument)." - declaration-name 'split-declarations - declaration-name - '*non-var-declarations* - '*var-declarations-with-arg* - '*var-declarations-without-arg*) - (push declaration-name *var-declarations-without-arg*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (case (car dname) - (%class (push `(declare (,@dname ,@form)) inner-decls)) - (t - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations - ;; on args when a next-method is - ;; involved, to prevent compiler - ;; warnings about ignored args being - ;; read. - (unless (and maybe-reads-params-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push - `(declare (,@dname ,@inners)) - inner-decls))))))))) - (setq body (cdr body))) + (setq decl (car body)) + (unless (and (consp decl) + (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let ((declaration-name (car form))) + (if (member declaration-name *non-var-declarations*) + (push `(declare ,form) outer-decls) + (let ((arg-p + (member declaration-name + *var-declarations-with-arg*)) + (non-arg-p + (member declaration-name + *var-declarations-without-arg*)) + (dname (list (pop form))) + (inners nil) (outers nil)) + (unless (or arg-p non-arg-p) + ;; FIXME: This warning, and perhaps the + ;; various *VAR-DECLARATIONS-FOO* and/or + ;; *NON-VAR-DECLARATIONS* variables, + ;; could probably go away now that we're not + ;; trying to be portable between different + ;; CLTL1 hosts the way PCL was. (Note that to + ;; do this right, we need to be able to handle + ;; user-defined (DECLAIM (DECLARATION FOO)) + ;; stuff.) + (warn "The declaration ~S is not understood by ~S.~@ + Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ + (Assuming it is a variable declaration without argument)." + declaration-name 'split-declarations + declaration-name + '*non-var-declarations* + '*var-declarations-with-arg* + '*var-declarations-without-arg*) + (push declaration-name *var-declarations-without-arg*)) + (when arg-p + (setq dname (append dname (list (pop form))))) + (case (car dname) + (%class (push `(declare (,@dname ,@form)) inner-decls)) + (t + (dolist (var form) + (if (member var args) + ;; Quietly remove IGNORE declarations + ;; on args when a next-method is + ;; involved, to prevent compiler + ;; warnings about ignored args being + ;; read. + (unless (and maybe-reads-params-p + (eq (car dname) 'ignore)) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push + `(declare (,@dname ,@inners)) + inner-decls))))))))) + (setq body (cdr body))) (values outer-decls inner-decls body))) ;;; Pull a name out of the %METHOD-NAME declaration in the function @@ -1032,8 +1032,8 @@ (declare (ignore real-body documentation)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl - (destructuring-bind (name) name-decl - name))))) + (destructuring-bind (name) name-decl + name))))) ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME ;;; declaration (which is a naming style internal to PCL) into an @@ -1044,80 +1044,80 @@ (defun name-method-lambda (method-lambda) (let ((method-name (body-method-name (cddr method-lambda)))) (if method-name - `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) - method-lambda))) + `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) + method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) (let (method-lambda-args - lmf ; becomes body of function - lmf-params) + lmf ; becomes body of function + lmf-params) (if (not (and (= 3 (length method-lambda)) - (= 2 (length (setq method-lambda-args (cadr method-lambda)))) - (consp (setq lmf (third method-lambda))) - (eq 'simple-lexical-method-functions (car lmf)) - (eq (car method-lambda-args) - (cadr (setq lmf-params (cadr lmf)))) - (eq (cadr method-lambda-args) - (caddr lmf-params)))) - `(list* :function ,(name-method-lambda method-lambda) - ',initargs) - (let* ((lambda-list (car lmf-params)) - (nreq 0) - (restp nil) - (args nil)) - (dolist (arg lambda-list) - (when (member arg '(&optional &rest &key)) - (setq restp t) - (return nil)) - (when (eq arg '&aux) - (return nil)) - (incf nreq) - (push arg args)) - (setq args (nreverse args)) - (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) - (make-method-initargs-form-internal1 - initargs (cddr lmf) args lmf-params restp))))) + (= 2 (length (setq method-lambda-args (cadr method-lambda)))) + (consp (setq lmf (third method-lambda))) + (eq 'simple-lexical-method-functions (car lmf)) + (eq (car method-lambda-args) + (cadr (setq lmf-params (cadr lmf)))) + (eq (cadr method-lambda-args) + (caddr lmf-params)))) + `(list* :function ,(name-method-lambda method-lambda) + ',initargs) + (let* ((lambda-list (car lmf-params)) + (nreq 0) + (restp nil) + (args nil)) + (dolist (arg lambda-list) + (when (member arg '(&optional &rest &key)) + (setq restp t) + (return nil)) + (when (eq arg '&aux) + (return nil)) + (incf nreq) + (push arg args)) + (setq args (nreverse args)) + (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) + (make-method-initargs-form-internal1 + initargs (cddr lmf) args lmf-params restp))))) (defun make-method-initargs-form-internal1 (initargs body req-args lmf-params restp) (multiple-value-bind (outer-decls inner-decls body-sans-decls) (split-declarations body req-args (or (getf (cdr lmf-params) :call-next-method-p) - (getf (cdr lmf-params) :setq-p))) + (getf (cdr lmf-params) :setq-p))) (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) + (args+rest-arg (if restp + (append req-args (list rest-arg)) + req-args))) `(list* - :fast-function - (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) + :fast-function + (,(if (body-method-name body) 'named-lambda 'lambda) + ,@(when (body-method-name body) ;; function name - (list (cons 'fast-method (body-method-name body)))) - (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args - ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.)) - ,@outer-decls - (declare (disable-package-locks pv-env)) - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol - pv-parameters)) - (declare (enable-package-locks pv-env)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (declare (enable-package-locks pv-env)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body-sans-decls))) - ',initargs)))) + (list (cons 'fast-method (body-method-name body)))) + (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args + ;; body of the function + (declare (ignorable .pv-cell. .next-method-call.)) + ,@outer-decls + (declare (disable-package-locks pv-env)) + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol + pv-parameters)) + (declare (enable-package-locks pv-env)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (declare (enable-package-locks pv-env)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls))) + ',initargs)))) ;;; Use arrays and hash tables and the fngen stuff to make this much ;;; better. It doesn't really matter, though, because a function @@ -1127,43 +1127,43 @@ (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf :arg-info)) - (nreq (car arg-info)) - (restp (cdr arg-info))) + (arg-info (method-function-get fmf :arg-info)) + (nreq (car arg-info)) + (restp (cdr arg-info))) (setq method-function - (lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (nm (car next-methods)) - (nms (cdr next-methods)) - (nmc (when nm - (make-method-call - :function (if (std-instance-p nm) - (method-function nm) - nm) - :call-method-args (list nms))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) - (name (cons 'slow-method (cdr fname)))) + (name (cons 'slow-method (cdr fname)))) (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) (defun get-method-function-pv-cell (method-function - method-args - &optional pv-table) + method-args + &optional pv-table) (let ((pv-table (or pv-table (method-function-pv-table method-function)))) (when pv-table (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) - (when pv-wrappers - (pv-table-lookup pv-table pv-wrappers)))))) + (when pv-wrappers + (pv-table-lookup pv-table pv-wrappers)))))) (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) @@ -1172,10 +1172,10 @@ (let (wrappers) (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers))) (let ((wrapper (wrapper-of arg))) - (push (if (invalid-wrapper-p wrapper) - (check-wrapper-validity wrapper) - wrapper) - wrappers))))) + (push (if (invalid-wrapper-p wrapper) + (check-wrapper-validity wrapper) + wrapper) + wrappers))))) (defun pv-wrappers-from-all-args (pv-table args) (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index c8401d4..ff5c160 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -114,8 +114,8 @@ (defmacro with-augmented-environment ((new-env old-env &key functions macros) &body body) `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) + ,functions + ,macros))) ,@body)) ;;; a unique tag to show that we're the intended caller of BOGO-FUN @@ -154,66 +154,66 @@ (sb!c::make-lexenv :default lexenv :vars (when (eql (caar macros) *key-to-walker-environment*) - (copy-tree (remove :lexical-var (fourth (cadar macros)) - :key #'cadr))) + (copy-tree (remove :lexical-var (fourth (cadar macros)) + :key #'cadr))) :funs (append (mapcar (lambda (f) - (cons (car f) - (sb!c::make-functional :lexenv lexenv))) - funs) - (mapcar (lambda (m) - (list* (car m) - 'sb!c::macro - (if (eq (car m) - *key-to-walker-environment*) - (walker-info-to-bogo-fun (cadr m)) - (coerce (cadr m) 'function)))) - macros))))) + (cons (car f) + (sb!c::make-functional :lexenv lexenv))) + funs) + (mapcar (lambda (m) + (list* (car m) + 'sb!c::macro + (if (eq (car m) + *key-to-walker-environment*) + (walker-info-to-bogo-fun (cadr m)) + (coerce (cadr m) 'function)))) + macros))))) (defun environment-function (env fn) (when env (let ((entry (assoc fn (sb!c::lexenv-funs env) :test #'equal))) (and entry - (sb!c::functional-p (cdr entry)) - (cdr entry))))) + (sb!c::functional-p (cdr entry)) + (cdr entry))))) (defun environment-macro (env macro) (when env (let ((entry (assoc macro (sb!c::lexenv-funs env) :test #'eq))) (and entry - (eq (cadr entry) 'sb!c::macro) + (eq (cadr entry) 'sb!c::macro) (if (eq macro *key-to-walker-environment*) - (values (bogo-fun-to-walker-info (cddr entry))) - (values (function-lambda-expression (cddr entry)))))))) + (values (bogo-fun-to-walker-info (cddr entry))) + (values (function-lambda-expression (cddr entry)))))))) ;;;; other environment hacking, not so SBCL-specific as the ;;;; environment hacking in the previous section (defmacro with-new-definition-in-environment - ((new-env old-env macrolet/flet/labels-form) &body body) + ((new-env old-env macrolet/flet/labels-form) &body body) (let ((functions (make-symbol "Functions")) - (macros (make-symbol "Macros"))) + (macros (make-symbol "Macros"))) `(let ((,functions ()) - (,macros ())) + (,macros ())) (ecase (car ,macrolet/flet/labels-form) - ((flet labels) - (dolist (fn (cadr ,macrolet/flet/labels-form)) - (push fn ,functions))) - ((macrolet) - (dolist (mac (cadr ,macrolet/flet/labels-form)) - (push (list (car mac) - (convert-macro-to-lambda (cadr mac) - (cddr mac) - ,old-env - (string (car mac)))) - ,macros)))) + ((flet labels) + (dolist (fn (cadr ,macrolet/flet/labels-form)) + (push fn ,functions))) + ((macrolet) + (dolist (mac (cadr ,macrolet/flet/labels-form)) + (push (list (car mac) + (convert-macro-to-lambda (cadr mac) + (cddr mac) + ,old-env + (string (car mac)))) + ,macros)))) (with-augmented-environment - (,new-env ,old-env :functions ,functions :macros ,macros) - ,@body)))) + (,new-env ,old-env :functions ,functions :macros ,macros) + ,@body)))) (defun convert-macro-to-lambda (llist body env &optional (name "dummy macro")) (let ((gensym (make-symbol name))) (eval-in-lexenv `(defmacro ,gensym ,llist ,@body) - (sb!c::make-restricted-lexenv env)) + (sb!c::make-restricted-lexenv env)) (macro-function gensym))) ;;;; the actual walker @@ -226,7 +226,7 @@ ;;; functions. This is what makes the NESTED-WALK-FORM facility work ;;; properly. (defmacro walker-environment-bind ((var env &rest key-args) - &body body) + &body body) `(with-augmented-environment (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) .,body)) @@ -237,16 +237,16 @@ (environment-macro env *key-to-walker-environment*)) (defun walker-environment-bind-1 (env &key (walk-function nil wfnp) - (walk-form nil wfop) - (declarations nil decp) - (lexical-vars nil lexp)) + (walk-form nil wfop) + (declarations nil decp) + (lexical-vars nil lexp)) (let ((lock (env-lock env))) (list (list *key-to-walker-environment* - (list (if wfnp walk-function (car lock)) - (if wfop walk-form (cadr lock)) - (if decp declarations (caddr lock)) - (if lexp lexical-vars (cadddr lock))))))) + (list (if wfnp walk-function (car lock)) + (if wfop walk-form (cadr lock)) + (if decp declarations (caddr lock)) + (if lexp lexical-vars (cadddr lock))))))) (defun env-walk-function (env) (car (env-lock env))) @@ -282,10 +282,10 @@ (if (not (member declaration *var-declarations*)) (error "~S is not a recognized variable declaration." declaration) (let ((id (or (var-lexical-p var env) var))) - (dolist (decl (env-declarations env)) - (when (and (eq (car decl) declaration) - (eq (cadr decl) id)) - (return decl)))))) + (dolist (decl (env-declarations env)) + (when (and (eq (car decl) declaration) + (eq (cadr decl) id)) + (return decl)))))) (defun var-special-p (var env) (or (not (null (var-declaration 'special var env))) @@ -318,13 +318,13 @@ ;;; having only 24 special forms as seriously as might be nice. There ;;; are (at least) 3 ways to lose: ;; -;;; 1 - Implementation x implements a Common Lisp special form as +;;; 1 - Implementation x implements a Common Lisp special form as ;;; a macro which expands into a special form which: -;;; - Is a common lisp special form (not likely) -;;; - Is not a common lisp special form (on the 3600 IF --> COND). +;;; - Is a common lisp special form (not likely) +;;; - Is not a common lisp special form (on the 3600 IF --> COND). ;;; ;;; * We can save ourselves from this case (second subcase really) -;;; by checking to see whether there is a template defined for +;;; by checking to see whether there is a template defined for ;;; something before we check to see whether we can macroexpand it. ;;; ;;; 2 - Implementation x implements a Common Lisp macro as a special form. @@ -339,8 +339,8 @@ ;;; 3 - Implementation x has a special form which is not on the list of ;;; Common Lisp special forms. ;;; -;;; * This is a bad sort of a screw and happens more than I would -;;; like to think, especially in the implementations which provide +;;; * This is a bad sort of a screw and happens more than I would +;;; like to think, especially in the implementations which provide ;;; more than just Common Lisp (3600, Xerox etc.). ;;; The fix is not terribly satisfactory, but will have to do for ;;; now. There is a hook in get walker-template which can get a @@ -354,23 +354,23 @@ `(get ,x 'walker-template)) (defmacro define-walker-template (name - &optional (template '(nil repeat (eval)))) + &optional (template '(nil repeat (eval)))) `(eval-when (:load-toplevel :execute) (setf (get-walker-template-internal ',name) ',template))) (defun get-walker-template (x context) (cond ((symbolp x) (get-walker-template-internal x)) - ((and (listp x) (eq (car x) 'lambda)) - '(lambda repeat (eval))) - (t - ;; FIXME: In an ideal world we would do something similar to - ;; COMPILER-ERROR here, replacing the form within the walker - ;; with an error-signalling form. This is slightly less - ;; pretty, but informative non the less. Best is the enemy of - ;; good, etc. - (error "Illegal function call in method body:~% ~S" - context)))) + ((and (listp x) (eq (car x) 'lambda)) + '(lambda repeat (eval))) + (t + ;; FIXME: In an ideal world we would do something similar to + ;; COMPILER-ERROR here, replacing the form within the walker + ;; with an error-signalling form. This is slightly less + ;; pretty, but informative non the less. Best is the enemy of + ;; good, etc. + (error "Illegal function call in method body:~% ~S" + context)))) ;;;; the actual templates @@ -413,11 +413,11 @@ (defvar *walk-form-expand-macros-p* nil) (defun walk-form (form - &optional environment - (walk-function - (lambda (subform context env) - (declare (ignore context env)) - subform))) + &optional environment + (walk-function + (lambda (subform context env) + (declare (ignore context env)) + subform))) (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) @@ -429,10 +429,10 @@ ;;; that is a list whose car is a symbol as follows: ;;; ;;; 1. If the program has particular knowledge about the symbol, -;;; process the form using special-purpose code. All of the -;;; standard special forms should fall into this category. +;;; process the form using special-purpose code. All of the +;;; standard special forms should fall into this category. ;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply -;;; either MACROEXPAND or MACROEXPAND-1 and start over. +;;; either MACROEXPAND or MACROEXPAND-1 and start over. ;;; 3. Otherwise, assume it is a function call. " (defun walk-form-internal (form context env) ;; First apply the walk-function to perform whatever translation @@ -440,102 +440,102 @@ ;; by walk-function is T then we don't recurse... (catch form (multiple-value-bind (newform walk-no-more-p) - (funcall (env-walk-function env) form context env) + (funcall (env-walk-function env) form context env) (catch newform - (cond - (walk-no-more-p newform) - ((not (eq form newform)) - (walk-form-internal newform context env)) - ((not (consp newform)) - (let ((symmac (car (variable-symbol-macro-p newform env)))) - (if symmac - (let ((newnewform (walk-form-internal (cddr symmac) - context - env))) - (if (eq newnewform (cddr symmac)) - (if *walk-form-expand-macros-p* newnewform newform) - newnewform)) - newform))) - (t - (let* ((fn (car newform)) - (template (get-walker-template fn newform))) - (if template - (if (symbolp template) - (funcall template newform context env) - (walk-template newform template context env)) - (multiple-value-bind (newnewform macrop) - (walker-environment-bind - (new-env env :walk-form newform) - (sb-xc:macroexpand-1 newform new-env)) - (cond - (macrop - (let ((newnewnewform (walk-form-internal newnewform - context - env))) - (if (eq newnewnewform newnewform) - (if *walk-form-expand-macros-p* newnewform newform) - newnewnewform))) - ((and (symbolp fn) - (not (fboundp fn)) - (special-operator-p fn)) - ;; This shouldn't happen, since this walker is now - ;; maintained as part of SBCL, so it should know - ;; about all the special forms that SBCL knows - ;; about. - (bug "unexpected special form ~S" fn)) - (t - ;; Otherwise, walk the form as if it's just a - ;; standard function call using a template for - ;; standard function call. - (walk-template - newnewform '(call repeat (eval)) context env)))))))))))) + (cond + (walk-no-more-p newform) + ((not (eq form newform)) + (walk-form-internal newform context env)) + ((not (consp newform)) + (let ((symmac (car (variable-symbol-macro-p newform env)))) + (if symmac + (let ((newnewform (walk-form-internal (cddr symmac) + context + env))) + (if (eq newnewform (cddr symmac)) + (if *walk-form-expand-macros-p* newnewform newform) + newnewform)) + newform))) + (t + (let* ((fn (car newform)) + (template (get-walker-template fn newform))) + (if template + (if (symbolp template) + (funcall template newform context env) + (walk-template newform template context env)) + (multiple-value-bind (newnewform macrop) + (walker-environment-bind + (new-env env :walk-form newform) + (sb-xc:macroexpand-1 newform new-env)) + (cond + (macrop + (let ((newnewnewform (walk-form-internal newnewform + context + env))) + (if (eq newnewnewform newnewform) + (if *walk-form-expand-macros-p* newnewform newform) + newnewnewform))) + ((and (symbolp fn) + (not (fboundp fn)) + (special-operator-p fn)) + ;; This shouldn't happen, since this walker is now + ;; maintained as part of SBCL, so it should know + ;; about all the special forms that SBCL knows + ;; about. + (bug "unexpected special form ~S" fn)) + (t + ;; Otherwise, walk the form as if it's just a + ;; standard function call using a template for + ;; standard function call. + (walk-template + newnewform '(call repeat (eval)) context env)))))))))))) (defun walk-template (form template context env) (if (atom template) (ecase template - ((eval function test effect return) - (walk-form-internal form :eval env)) - ((quote nil) form) - (set - (walk-form-internal form :set env)) - ((lambda call) - (cond ((legal-fun-name-p form) - form) - (t (walk-form-internal form context env))))) + ((eval function test effect return) + (walk-form-internal form :eval env)) + ((quote nil) form) + (set + (walk-form-internal form :set env)) + ((lambda call) + (cond ((legal-fun-name-p form) + form) + (t (walk-form-internal form context env))))) (case (car template) - (repeat - (walk-template-handle-repeat form - (cdr template) - ;; For the case where nothing - ;; happens after the repeat - ;; optimize away the call to - ;; LENGTH. - (if (null (cddr template)) - () - (nthcdr (- (length form) - (length - (cddr template))) - form)) - context - env)) - (if - (walk-template form - (if (if (listp (cadr template)) - (eval (cadr template)) - (funcall (cadr template) form)) - (caddr template) - (cadddr template)) - context - env)) - (remote - (walk-template form (cadr template) context env)) - (otherwise - (cond ((atom form) form) - (t (recons form - (walk-template - (car form) (car template) context env) - (walk-template - (cdr form) (cdr template) context env)))))))) + (repeat + (walk-template-handle-repeat form + (cdr template) + ;; For the case where nothing + ;; happens after the repeat + ;; optimize away the call to + ;; LENGTH. + (if (null (cddr template)) + () + (nthcdr (- (length form) + (length + (cddr template))) + form)) + context + env)) + (if + (walk-template form + (if (if (listp (cadr template)) + (eval (cadr template)) + (funcall (cadr template) form)) + (caddr template) + (cadddr template)) + context + env)) + (remote + (walk-template form (cadr template) context env)) + (otherwise + (cond ((atom form) form) + (t (recons form + (walk-template + (car form) (car template) context env) + (walk-template + (cdr form) (cdr template) context env)))))))) (defun walk-template-handle-repeat (form template stop-form context env) (if (eq form stop-form) @@ -544,35 +544,35 @@ form template (car template) stop-form context env))) (defun walk-template-handle-repeat-1 (form template repeat-template - stop-form context env) + stop-form context env) (cond ((null form) ()) - ((eq form stop-form) - (if (null repeat-template) - (walk-template stop-form (cdr template) context env) - (error "while handling code walker REPEAT: + ((eq form stop-form) + (if (null repeat-template) + (walk-template stop-form (cdr template) context env) + (error "while handling code walker REPEAT: ~%ran into STOP while still in REPEAT template"))) - ((null repeat-template) - (walk-template-handle-repeat-1 - form template (car template) stop-form context env)) - (t - (recons form - (walk-template (car form) (car repeat-template) context env) - (walk-template-handle-repeat-1 (cdr form) - template - (cdr repeat-template) - stop-form - context - env))))) + ((null repeat-template) + (walk-template-handle-repeat-1 + form template (car template) stop-form context env)) + (t + (recons form + (walk-template (car form) (car repeat-template) context env) + (walk-template-handle-repeat-1 (cdr form) + template + (cdr repeat-template) + stop-form + context + env))))) (defun walk-repeat-eval (form env) (and form (recons form - (walk-form-internal (car form) :eval env) - (walk-repeat-eval (cdr form) env)))) + (walk-form-internal (car form) :eval env) + (walk-repeat-eval (cdr form) env)))) (defun recons (x car cdr) (if (or (not (eq (car x) car)) - (not (eq (cdr x) cdr))) + (not (eq (cdr x) cdr))) (cons car cdr) x)) @@ -587,98 +587,98 @@ (defun relist-internal (x args *p) (if (null (cdr args)) (if *p - (car args) - (recons x (car args) nil)) + (car args) + (recons x (car args) nil)) (recons x - (car args) - (relist-internal (cdr x) (cdr args) *p)))) + (car args) + (relist-internal (cdr x) (cdr args) *p)))) ;;;; special walkers (defun walk-declarations (body fn env - &optional doc-string-p declarations old-body - &aux (form (car body)) macrop new-form) - (cond ((and (stringp form) ;might be a doc string - (cdr body) ;isn't the returned value - (null doc-string-p) ;no doc string yet - (null declarations)) ;no declarations yet - (recons body - form - (walk-declarations (cdr body) fn env t))) - ((and (listp form) (eq (car form) 'declare)) - ;; We got ourselves a real live declaration. Record it, look - ;; for more. - (dolist (declaration (cdr form)) - (let ((type (car declaration)) - (name (cadr declaration)) - (args (cddr declaration))) - (if (member type *var-declarations*) - (note-declaration `(,type - ,(or (var-lexical-p name env) name) - ,.args) - env) - (note-declaration declaration env)) - (push declaration declarations))) - (recons body - form - (walk-declarations - (cdr body) fn env doc-string-p declarations))) - ((and form - (listp form) - (null (get-walker-template (car form) form)) - (progn - (multiple-value-setq (new-form macrop) - (sb-xc:macroexpand-1 form env)) - macrop)) - ;; This form was a call to a macro. Maybe it expanded - ;; into a declare? Recurse to find out. - (walk-declarations (recons body new-form (cdr body)) - fn env doc-string-p declarations - (or old-body body))) - (t - ;; Now that we have walked and recorded the declarations, - ;; call the function our caller provided to expand the body. - ;; We call that function rather than passing the real-body - ;; back, because we are RECONSING up the new body. - (funcall fn (or old-body body) env)))) + &optional doc-string-p declarations old-body + &aux (form (car body)) macrop new-form) + (cond ((and (stringp form) ;might be a doc string + (cdr body) ;isn't the returned value + (null doc-string-p) ;no doc string yet + (null declarations)) ;no declarations yet + (recons body + form + (walk-declarations (cdr body) fn env t))) + ((and (listp form) (eq (car form) 'declare)) + ;; We got ourselves a real live declaration. Record it, look + ;; for more. + (dolist (declaration (cdr form)) + (let ((type (car declaration)) + (name (cadr declaration)) + (args (cddr declaration))) + (if (member type *var-declarations*) + (note-declaration `(,type + ,(or (var-lexical-p name env) name) + ,.args) + env) + (note-declaration declaration env)) + (push declaration declarations))) + (recons body + form + (walk-declarations + (cdr body) fn env doc-string-p declarations))) + ((and form + (listp form) + (null (get-walker-template (car form) form)) + (progn + (multiple-value-setq (new-form macrop) + (sb-xc:macroexpand-1 form env)) + macrop)) + ;; This form was a call to a macro. Maybe it expanded + ;; into a declare? Recurse to find out. + (walk-declarations (recons body new-form (cdr body)) + fn env doc-string-p declarations + (or old-body body))) + (t + ;; Now that we have walked and recorded the declarations, + ;; call the function our caller provided to expand the body. + ;; We call that function rather than passing the real-body + ;; back, because we are RECONSING up the new body. + (funcall fn (or old-body body) env)))) (defun walk-unexpected-declare (form context env) (declare (ignore context env)) (warn "encountered ~S ~_in a place where a DECLARE was not expected" - form) + form) form) (defun walk-arglist (arglist context env &optional (destructuringp nil) - &aux arg) + &aux arg) (cond ((null arglist) ()) - ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords) - (note-lexical-binding arg env)) - (recons arglist - arg - (walk-arglist (cdr arglist) - context - env - (and destructuringp - (not (member arg - lambda-list-keywords)))))) - ((consp arg) - (prog1 (recons arglist - (if destructuringp - (walk-arglist arg context env destructuringp) - (relist* arg - (car arg) - (walk-form-internal (cadr arg) :eval env) - (cddr arg))) - (walk-arglist (cdr arglist) context env nil)) - (if (symbolp (car arg)) - (note-lexical-binding (car arg) env) - (note-lexical-binding (cadar arg) env)) - (or (null (cddr arg)) - (not (symbolp (caddr arg))) - (note-lexical-binding (caddr arg) env)))) - (t - (error "can't understand something in the arglist ~S" arglist)))) + ((symbolp (setq arg (car arglist))) + (or (member arg lambda-list-keywords) + (note-lexical-binding arg env)) + (recons arglist + arg + (walk-arglist (cdr arglist) + context + env + (and destructuringp + (not (member arg + lambda-list-keywords)))))) + ((consp arg) + (prog1 (recons arglist + (if destructuringp + (walk-arglist arg context env destructuringp) + (relist* arg + (car arg) + (walk-form-internal (cadr arg) :eval env) + (cddr arg))) + (walk-arglist (cdr arglist) context env nil)) + (if (symbolp (car arg)) + (note-lexical-binding (car arg) env) + (note-lexical-binding (cadar arg) env)) + (or (null (cddr arg)) + (not (symbolp (caddr arg))) + (note-lexical-binding (caddr arg) env)))) + (t + (error "can't understand something in the arglist ~S" arglist)))) (defun walk-let (form context env) (walk-let/let* form context env nil)) @@ -689,177 +689,177 @@ (defun walk-let/let* (form context old-env sequentialp) (walker-environment-bind (new-env old-env) (let* ((let/let* (car form)) - (bindings (cadr form)) - (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (bindings (cadr form)) + (body (cddr form)) + (walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + sequentialp)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* - form let/let* walked-bindings walked-body)))) + form let/let* walked-bindings walked-body)))) (defun walk-locally (form context env) (declare (ignore context)) (let* ((locally (car form)) - (body (cdr form)) - (walked-body - (walk-declarations body #'walk-repeat-eval env))) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval env))) (relist* form locally walked-body))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) (if (some (lambda (var) - (variable-symbol-macro-p var env)) - vars) - (let* ((temps (mapcar (lambda (var) - (declare (ignore var)) - (gensym)) - vars)) - (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) - vars - temps)) - (expanded `(multiple-value-bind ,temps ,(caddr form) - ,@sets)) - (walked (walk-form-internal expanded context env))) - (if (eq walked expanded) - form - walked)) - (walk-template form '(nil (repeat (set)) eval) context env)))) + (variable-symbol-macro-p var env)) + vars) + (let* ((temps (mapcar (lambda (var) + (declare (ignore var)) + (gensym)) + vars)) + (sets (mapcar (lambda (var temp) `(setq ,var ,temp)) + vars + temps)) + (expanded `(multiple-value-bind ,temps ,(caddr form) + ,@sets)) + (walked (walk-form-internal expanded context env))) + (if (eq walked expanded) + form + walked)) + (walk-template form '(nil (repeat (set)) eval) context env)))) (defun walk-multiple-value-bind (form context old-env) (walker-environment-bind (new-env old-env) (let* ((mvb (car form)) - (bindings (cadr form)) - (mv-form (walk-template (caddr form) 'eval context old-env)) - (body (cdddr form)) - walked-bindings - (walked-body - (walk-declarations - body - (lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) - new-env))) + (bindings (cadr form)) + (mv-form (walk-template (caddr form) 'eval context old-env)) + (body (cdddr form)) + walked-bindings + (walked-body + (walk-declarations + body + (lambda (real-body real-env) + (setq walked-bindings + (walk-bindings-1 bindings + old-env + new-env + context + nil)) + (walk-repeat-eval real-body real-env)) + new-env))) (relist* form mvb walked-bindings mv-form walked-body)))) (defun walk-bindings-1 (bindings old-env new-env context sequentialp) (and bindings (let ((binding (car bindings))) - (recons bindings - (if (symbolp binding) - (prog1 binding - (note-lexical-binding binding new-env)) - (prog1 (relist* binding - (car binding) - (walk-form-internal (cadr binding) - context - (if sequentialp - new-env - old-env)) - ;; Save cddr for DO/DO*; it is - ;; the next value form. Don't - ;; walk it now, though. - (cddr binding)) - (note-lexical-binding (car binding) new-env))) - (walk-bindings-1 (cdr bindings) - old-env - new-env - context - sequentialp))))) + (recons bindings + (if (symbolp binding) + (prog1 binding + (note-lexical-binding binding new-env)) + (prog1 (relist* binding + (car binding) + (walk-form-internal (cadr binding) + context + (if sequentialp + new-env + old-env)) + ;; Save cddr for DO/DO*; it is + ;; the next value form. Don't + ;; walk it now, though. + (cddr binding)) + (note-lexical-binding (car binding) new-env))) + (walk-bindings-1 (cdr bindings) + old-env + new-env + context + sequentialp))))) (defun walk-bindings-2 (bindings walked-bindings context env) (and bindings (let ((binding (car bindings)) - (walked-binding (car walked-bindings))) - (recons bindings - (if (symbolp binding) - binding - (relist* binding - (car walked-binding) - (cadr walked-binding) - (walk-template (cddr binding) - '(eval) - context - env))) - (walk-bindings-2 (cdr bindings) - (cdr walked-bindings) - context - env))))) + (walked-binding (car walked-bindings))) + (recons bindings + (if (symbolp binding) + binding + (relist* binding + (car walked-binding) + (cadr walked-binding) + (walk-template (cddr binding) + '(eval) + context + env))) + (walk-bindings-2 (cdr bindings) + (cdr walked-bindings) + context + env))))) (defun walk-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((arglist (cadr form)) - (body (cddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (body (cddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - (car form) - walked-arglist - walked-body)))) + (car form) + walked-arglist + walked-body)))) (defun walk-named-lambda (form context old-env) (walker-environment-bind (new-env old-env) (let* ((name (second form)) (arglist (third form)) - (body (cdddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) + (body (cdddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) (relist* form - (car form) + (car form) name - walked-arglist - walked-body)))) + walked-arglist + walked-body)))) (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) - (tail (cdr form))) - (loop (when (null tail) (return (nreverse rforms))) - (let ((var (pop tail)) (val (pop tail))) - (push `(setq ,var ,val) rforms))))) - (walked (walk-repeat-eval expanded env))) - (if (eq expanded walked) - form - `(progn ,@walked))) + (tail (cdr form))) + (loop (when (null tail) (return (nreverse rforms))) + (let ((var (pop tail)) (val (pop tail))) + (push `(setq ,var ,val) rforms))))) + (walked (walk-repeat-eval expanded env))) + (if (eq expanded walked) + form + `(progn ,@walked))) (let* ((var (cadr form)) - (val (caddr form)) - (symmac (car (variable-symbol-macro-p var env)))) - (if symmac - (let* ((expanded `(setf ,(cddr symmac) ,val)) - (walked (walk-form-internal expanded context env))) - (if (eq expanded walked) - form - walked)) - (relist form 'setq - (walk-form-internal var :set env) - (walk-form-internal val :eval env)))))) + (val (caddr form)) + (symmac (car (variable-symbol-macro-p var env)))) + (if symmac + (let* ((expanded `(setf ,(cddr symmac) ,val)) + (walked (walk-form-internal expanded context env))) + (if (eq expanded walked) + form + walked)) + (relist form 'setq + (walk-form-internal var :set env) + (walk-form-internal val :eval env)))))) (defun walk-symbol-macrolet (form context old-env) (declare (ignore context)) (let* ((bindings (cadr form)) - (body (cddr form))) + (body (cddr form))) (walker-environment-bind - (new-env old-env - :lexical-vars - (append (mapcar (lambda (binding) - `(,(car binding) - sb!sys:macro . ,(cadr binding))) - bindings) - (env-lexical-variables old-env))) + (new-env old-env + :lexical-vars + (append (mapcar (lambda (binding) + `(,(car binding) + sb!sys:macro . ,(cadr binding))) + bindings) + (env-lexical-variables old-env))) (relist* form 'symbol-macrolet bindings - (walk-declarations body #'walk-repeat-eval new-env))))) + (walk-declarations body #'walk-repeat-eval new-env))))) (defun walk-tagbody (form context env) (recons form (car form) (walk-tagbody-1 (cdr form) context env))) @@ -867,77 +867,77 @@ (defun walk-tagbody-1 (form context env) (and form (recons form - (walk-form-internal (car form) - (if (symbolp (car form)) 'quote context) - env) - (walk-tagbody-1 (cdr form) context env)))) + (walk-form-internal (car form) + (if (symbolp (car form)) 'quote context) + env) + (walk-tagbody-1 (cdr form) context env)))) (defun walk-macrolet (form context old-env) (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) + nil + :walk-function (env-walk-function old-env)) (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions - (relist* definition - (car definition) - (walk-arglist (cadr definition) - context - macro-env - t) - (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (relist* form + (car form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-flet (form context old-env) (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context old-env) + (walk-definitions (cdr definitions)))))) (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-labels (form context old-env) (with-new-definition-in-environment (new-env old-env form) (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context new-env) - (walk-definitions (cdr definitions)))))) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env)))))) (defun walk-if (form context env) (destructuring-bind (if predicate arm1 &optional arm2) form (declare (ignore if)) ; should be 'IF (relist form - 'if - (walk-form-internal predicate context env) - (walk-form-internal arm1 context env) - (walk-form-internal arm2 context env)))) + 'if + (walk-form-internal predicate context env) + (walk-form-internal arm1 context env) + (walk-form-internal arm2 context env)))) ;;;; examples diff --git a/version.lisp-expr b/version.lisp-expr index 672c878..710f072 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".) -"0.9.2.49" +"0.9.2.50"