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))
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)
(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))
\f
;;; 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)
(initargs :reader initarg-error-initargs :initarg :initargs))
(:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
(:report (lambda (condition stream)
- (format stream "~@<Invalid initialization argument~P: ~2I~_~
+ (format stream "~@<Invalid initialization argument~P: ~2I~_~
~<~{~S~^, ~} ~@:>~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 ()))
;; 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))
;; 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))
;;; 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))
;; 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
(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
;;; 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
(defmacro get-instance-wrapper-or-nil (inst)
(once-only ((wrapper `(wrapper-of ,inst)))
`(if (typep ,wrapper 'wrapper)
- ,wrapper
- nil)))
+ ,wrapper
+ nil)))
\f
;;;; support for useful hashing of PCL instances
;; 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
(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))
(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)
(/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")
(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)))))
\f
;;;; FIND-CLASS
;;;;
(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")
(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)
(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))
\f
;;; This DEFVAR was originally in defs.lisp, now moved here.
;;;
(/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")
;;; 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)))
(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))
(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)
(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)))))
(find-class 'standard-generic-function))
\f
(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)
\f
;;; 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))
(: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
- "~@<The generic function ~S takes ~D required argument~:P; ~
+ 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
+ "~@<The generic function ~S takes ~D required argument~:P; ~
was asked to find a method with specializers ~S~@:>"
- :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 "~@<There is no method on ~S with ~
+ ((null errorp) nil)
+ (t
+ (error "~@<There is no method on ~S with ~
~:[no qualifiers~;~:*qualifiers ~S~] ~
and specializers ~S.~@:>"
- 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))
\f
;;; 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
;;; 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
;; 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")))))
\f
(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))
(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))))
(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 "~@<The method ~S is already part of the generic ~
- function ~S; it can't be added to another generic ~
- function until it is removed from the first one.~@:>"
- 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 "~@<Invalid qualifiers for standard method combination ~
+ (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 "~@<Invalid qualifiers for standard method combination ~
in method ~S:~2I~_~S.~@:>"
- 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 "~@<Invalid qualifiers for ~S method combination ~
+ 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 "~@<Invalid qualifiers for ~S method combination ~
in method ~S:~2I~_~S.~@:>"
- 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)
\f
(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)
(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
(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
))
\f
(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
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))
(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 "~@<The function ~2I~_~S ~I~_requires ~
+ :format-control "~@<The function ~2I~_~S ~I~_requires ~
at least ~W argument~:P.~:>"
- :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)
(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)
(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)
(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:
;;; 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)
(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)
(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))
(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)
(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)
(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))))
(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))))
\f
;;; The value returned by compute-discriminating-function is a function
;;; (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
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; (lambda (arg)
-;;; (cond (<some condition>
-;;; <store some info in the generic function>
-;;; (set-funcallable-instance-function
-;;; gf
-;;; (compute-discriminating-function gf))
-;;; (funcall gf arg))
-;;; (t
-;;; <call-a-method-of-gf>))))
+;;; (cond (<some condition>
+;;; <store some info in the generic function>
+;;; (set-funcallable-instance-function
+;;; gf
+;;; (compute-discriminating-function gf))
+;;; (funcall gf arg))
+;;; (t
+;;; <call-a-method-of-gf>))))
;;;
;;; Whereas this code would not be legal:
;;;
;;; (defmethod compute-discriminating-function ((gf my-generic-function))
;;; (lambda (arg)
-;;; (cond (<some condition>
-;;; (set-funcallable-instance-function
-;;; gf
-;;; (lambda (a) ..))
-;;; (funcall gf arg))
-;;; (t
-;;; <call-a-method-of-gf>))))
+;;; (cond (<some condition>
+;;; (set-funcallable-instance-function
+;;; gf
+;;; (lambda (a) ..))
+;;; (funcall gf arg))
+;;; (t
+;;; <call-a-method-of-gf>))))
;;;
;;; 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))
(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))))))
\f
(defmethod (setf class-name) :before (new-value (class class))
(let ((classoid (find-classoid (class-name class))))
(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)))
(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)))
\f
;;; 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 ()))
(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)))
(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))
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)
\f
(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
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))
(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)))))
(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))))
(format s "~@<The slot ~S has neither ~S nor ~S ~
allocation, so it can't be ~A by the default ~
~S method.~@:>"
- (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
(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))))))
(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
(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
(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
((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)
(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)
(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 "~@<The wrapper for class ~S does not have ~
+ (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 "~@<The wrapper for class ~S does not have ~
the slot ~S~@:>"
- class slot-name))))
- (slot-value instance slot-name)))))))
+ class slot-name))))
+ (slot-value instance slot-name)))))))
\f
(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))))
(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)
(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")))))
\f
(defun find-slot-definition (class slot-name)
(dolist (slot (class-slots class) nil)
(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)
(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
(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."))
\f
(defmethod slot-missing
- ((class t) instance slot-name operation &optional new-value)
+ ((class t) instance slot-name operation &optional new-value)
(error "~@<When attempting to ~A, the slot ~S is missing from the ~
object ~S.~@:>"
- (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))
;;; 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)))
(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
(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))
(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:
;;; 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))))
(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)
;;; 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))
(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))))))
\f
;;; This hash table is used to store the direct methods and direct generic
*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))))
(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)
(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
\f
(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
- "~@<slot names with the same SYMBOL-NAME but ~
+ (style-warn
+ ;; FIXME: the indentation request ("~4I")
+ ;; below appears not to do anything. Finding
+ ;; out why would be nice. -- CSR, 2003-04-24
+ "~@<slot names with the same SYMBOL-NAME but ~
different SYMBOL-PACKAGE (possible package problem) ~
for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
- 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))
;;; 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)
;; 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))
(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)
(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))
((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)))
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)
(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))
(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)
(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))))))
(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))))))
\f
(defun add-direct-subclasses (class supers)
(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.
;; 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
(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)))
(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)
(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)
(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))
\f
(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)))
\f
;;;; protocols for constructing direct and effective slot definitions
(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))
(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)))
(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)
(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))))
\f
;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
;;; to make the method object. They have to use make-a-method which
(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))
(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)))
(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)
(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))))
\f
;;; What this does depends on which of the four possible values of
;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
;; 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))
;;; 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))
(lambda (condition stream)
;; Don't try to print the structure, since it probably won't work.
(format stream
- "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
- (type-of (obsolete-structure-datum condition))))))
+ "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
+ (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)))
(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)))
\f
(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
(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.
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))
;;;; 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*)
(def class-slots))
(defmethod validate-superclass ((c slot-class)
- (f forward-referenced-class))
+ (f forward-referenced-class))
t)
\f
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
(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))
(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
(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)))
(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)))))
\f
(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)
(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)
\f
(defvar *pvs* (make-hash-table :test 'equal))
(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
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)
||#
'#())
(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)
(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))
(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)))
\f
(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))
\f
(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
;;; 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
(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)
(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
;;; 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
`(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)
;;; 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))
(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))
: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.
;;;
(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)
;;; * 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))
;;;; 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
,@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))
(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
(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
(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
(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)))
(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
(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
(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))))))))
\f
;;;; 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)))
\f
;;;; the actual walker
;;; 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))
(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)))
(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)))
;;; 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.
;;; 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
`(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))))
\f
;;;; the actual templates
(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)))
;;; 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
;; 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)
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))
(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))))
\f
;;;; 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))
(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)))
(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))))
\f
;;;; examples
;;; 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"
projects / sbcl.git / commitdiff