mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-13 21:02:47 -08:00
Code Issues Projects Releases Packages Wiki Activity

Precompute the list of keywords in a method

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-06-20 19:15:14 +02:00
parent f77ae37309
commit d88da2f8f3
5 changed files with 52 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/clos/change.lsp
View file

@ -43,11 +43,12 @@
(setf added-slots (set-difference (mapcar #'slot-definition-name new-local-slotds)
(mapcar #'slot-definition-name old-local-slotds)))
(check-initargs (class-of new-data) initargs
(append (compute-applicable-methods
#'update-instance-for-different-class
(list old-data new-data))
(compute-applicable-methods
#'shared-initialize (list new-data added-slots))))
(valid-keywords-from-methods
(compute-applicable-methods
#'update-instance-for-different-class
(list old-data new-data))
(compute-applicable-methods
#'shared-initialize (list new-data added-slots))))
(apply #'shared-initialize new-data added-slots initargs)))
(defmethod change-class ((instance standard-object) (new-class std-class)
@ -115,12 +116,13 @@
&rest initargs)
(declare (ignore discarded-slots property-list))
(check-initargs (class-of instance) initargs
(append (compute-applicable-methods
#'update-instance-for-redefined-class
(list instance added-slots discarded-slots property-list))
(compute-applicable-methods
#'shared-initialize
(list instance added-slots))))
(valid-keywords-from-methods
(compute-applicable-methods
#'update-instance-for-redefined-class
(list instance added-slots discarded-slots property-list))
(compute-applicable-methods
#'shared-initialize
(list instance added-slots))))
(apply #'shared-initialize instance added-slots initargs))
(defun update-instance (instance)

3
src/clos/kernel.lsp
View file

@ -140,7 +140,8 @@
(qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers)
(function :initarg :function :accessor method-function)
(documentation :initform nil :initarg documentation)
(plist :initform nil :initarg :plist :accessor method-plist))))
(plist :initform nil :initarg :plist :accessor method-plist)
(keywords :initform nil :accessor method-keywords))))
#.(create-accessors +standard-method-slots+ 'standard-method)

12
src/clos/method.lsp
View file

@ -263,6 +263,16 @@ have disappeared."
;;; ----------------------------------------------------------------------
;;; operations
(defun add-method-keywords (method)
(multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys)
(si::process-lambda-list (method-lambda-list method) t)
(setf (method-keywords method)
(if allow-other-keys
't
(loop for k in (rest keywords) by #'cddddr
collect k)))
method))
(defun make-method (method-class qualifiers specializers lambda-list
fun plist options)
(declare (ignore options))
@ -276,7 +286,7 @@ have disappeared."
(method-specializers method) specializers
(method-qualifiers method) qualifiers
(method-plist method) plist)
method))
(add-method-keywords method)))
;;; early version used during bootstrap
(defun method-p (x)

52
src/clos/standard.lsp
View file

@ -20,10 +20,11 @@
(defmethod reinitialize-instance ((instance T) &rest initargs)
(check-initargs (class-of instance) initargs
(append (compute-applicable-methods
#'reinitialize-instance (list instance))
(compute-applicable-methods
#'shared-initialize (list instance t))))
(valid-keywords-from-methods
(compute-applicable-methods
#'reinitialize-instance (list instance))
(compute-applicable-methods
#'shared-initialize (list instance t))))
(apply #'shared-initialize instance '() initargs))
(defmethod shared-initialize ((instance T) slot-names &rest initargs)
@ -110,12 +111,13 @@
;; (Paul Dietz's ANSI test suite, test CLASS-24.4)
(setf initargs (add-default-initargs class initargs))
(check-initargs class initargs
(append (compute-applicable-methods
#'allocate-instance (list class))
(compute-applicable-methods
#'initialize-instance (list (class-prototype class)))
(compute-applicable-methods
#'shared-initialize (list (class-prototype class) t))))
(valid-keywords-from-methods
(compute-applicable-methods
#'allocate-instance (list class))
(compute-applicable-methods
#'initialize-instance (list (class-prototype class)))
(compute-applicable-methods
#'shared-initialize (list (class-prototype class) t))))
(let ((instance (apply #'allocate-instance class initargs)))
(apply #'initialize-instance instance initargs)
instance))
@ -695,30 +697,22 @@ because it contains a reference to the undefined class~% ~A"
;;; on SHARED-INITIALIZE, REINITIALIZE-INSTANCE, etc. (See ANSI 7.1.2)
;;;
(defun valid-keywords-from-methods (methods)
(declare (si::c-local))
;; Given a list of methods, build up the list of valid keyword arguments
(do ((m methods (rest m))
(keys '()))
((null m)
(values keys nil))
(multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys)
(si::process-lambda-list (method-lambda-list (first m)) t)
(when allow-other-keys
(return (values nil t)))
(do ((k (rest keywords) (cddddr k)))
((null k))
(push (first k) keys)))))
(defun valid-keywords-from-methods (&rest method-lists)
(let ((keys '()))
(dolist (methods method-lists keys)
;; Given a list of methods, build up the list of valid keyword arguments
(dolist (m methods)
(let ((keywords (method-keywords m)))
(if (eq keywords t)
(return-from valid-keywords-from-methods t)
(setf keys (append keywords keys))))))))
(defun check-initargs (class initargs &optional methods
(defun check-initargs (class initargs &optional method-initargs
(slots (class-slots class)))
;; First get all initargs which have been declared in the given
;; methods, then check the list of initargs declared in the slots
;; of the class.
(multiple-value-bind (method-initargs allow-other-keys)
(valid-keywords-from-methods methods)
(when allow-other-keys
(return-from check-initargs))
(unless (eq method-initargs t)
(do* ((name-loc initargs (cddr name-loc))
(allow-other-keys nil)
(allow-other-keys-found nil)

3
src/clos/stdmethod.lsp
View file

@ -56,3 +56,6 @@
(defclass standard-reader-method (standard-accessor-method) ())
(defclass standard-writer-method (standard-accessor-method) ())
(defmethod shared-initialized ((method standard-method) &rest initargs)
(add-method-keywords (call-next-method)))