diff --git a/src/CHANGELOG b/src/CHANGELOG index b228f8b53..035e53288 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -56,6 +56,11 @@ ECL 12.2.2: - Implemented the class CLOS:METAOBJECT + - Implemented SPECIALIZER and EQL-SPECIALIZER, together with + ADD-DIRECT-METHOD, REMOVE-DIRECT-METHOD, SPECIALIZER-DIRECT-METHODS, + SPECIALIZER-DIRECT-GENERIC-FUNCTIONS and EQL-SPECIALIZER-OBJECT. ECL now + uses these objects internally for method dispatch. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index be90bfdab..bea0b9c93 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -80,7 +80,13 @@ ;;; ---------------------------------------------------------------------- ;;; Fixup -(dolist (method-info *early-methods*) + +(defun register-method-with-specializers (method) + (declare (si::c-local)) + (loop for spec in (method-specializers method) + do (add-direct-method spec method))) + +(dolist (method-info *early-methods* (makunbound '*EARLY-METHODS*)) (let* ((method-name (car method-info)) (gfun (fdefinition method-name)) (standard-method-class (find-class 'standard-method))) @@ -102,8 +108,9 @@ (t old-class)))) (si::instance-sig-set gfun) + (register-method-with-specializers method) ) - (makunbound '*EARLY-METHODS*))) + )) ;;; ---------------------------------------------------------------------- @@ -202,7 +209,8 @@ their lambda lists ~A and ~A are not congruent." (set-generic-function-dispatch gf) ;; iv) Update dependents. (update-dependents gf (list 'add-method method)) - ;; + ;; v) Register with specializers + (register-method-with-specializers method) gf) (defun function-to-method (name signature) @@ -219,6 +227,8 @@ their lambda lists ~A and ~A are not congruent." (delete method (generic-function-methods gf)) (method-generic-function method) nil) (si:clear-gfun-hash gf) + (loop for spec in (method-specializers method) + do (add-direct-method spec method)) (update-dependents gf (list 'remove-method method)) gf) diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index 1b3204bea..25b84fcbc 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -89,3 +89,25 @@ (or (gethash object table nil) (setf (gethash object table) (make-instance 'eql-specializer :object object)))))) + +(defmethod add-direct-method ((spec specializer) (method method)) + (pushnew method (specializer-direct-methods spec)) + (let ((gf (method-generic-function method))) + (pushnew gf (specializer-direct-generic-functions spec))) + (values)) + +(defmethod remove-direct-method ((spec specializer) (method method)) + (let* ((gf (method-generic-function method)) + (methods (delete method (specializer-direct-methods spec)))) + (setf (specializer-direct-methods spec) methods) + (unless (find gf methods :key #'method-generic-function) + (setf (specializer-direct-generic-functions spec) + (delete gf (specializer-direct-generic-functions spec)))) + (values))) + +(defmethod remove-direct-method ((spec eql-specializer) (method method)) + (mp:with-lock (*eql-specializer-lock*) + (call-next-method) + (unless (specializer-direct-methods spec) + (remhash spec *eql-specializer-hash*))) + (values))