diff --git a/src/CHANGELOG b/src/CHANGELOG index 344eff6d4..3011f1f09 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -93,7 +93,12 @@ ECL 0.9i or use SLOT-VALUE. It should be set to NIL when one intends to redefine the SLOT-*-USING-CLASS methods. - - Implemented [FUNCALLABLE-]STANDARD-INSTANCE-ACCESS. + - Implemented [FUNCALLABLE-]STANDARD-INSTANCE-ACCESS. They are synonyms for + SI:INSTANCE-REF and are, as such, inlined and _very_ unsafe. Use with care. + + - Two nonstandard slots have been removed from standard-methods. Keeping track + of which methods were in a defgeneric function is done using the property + list of the methods. * Errors fixed: diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 5e5ee0be4..a87c23c6d 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -23,12 +23,9 @@ (let* ((output `(ensure-generic-function ',function-specifier :delete-methods t ,@option-list))) (if method-list - `(prog1 ,output - ,@(mapcar #'(lambda (m) - `(setf (method-from-defgeneric-p - (defmethod ,function-specifier ,@m)) - t)) - method-list)) + `(associate-methods-to-gfun ,output + ,@(mapcar #'(lambda (m) `(defmethod ,function-specifier ,@m)) + method-list)) output)) ))) @@ -179,6 +176,11 @@ (compute-g-f-spec-list gfun) gfun) +(defun associate-methods-to-gfun (gfun &rest methods) + (dolist (method methods) + (setf (getf (method-plist method) :method-from-defgeneric-p) t)) + gfun) + (defmethod ensure-generic-function-using-class ((gfun generic-function) name &rest args &key (method-class 'STANDARD-METHOD) (generic-function-class (class-of gfun)) @@ -199,7 +201,7 @@ generic-function-class)) (when delete-methods (dolist (m (copy-list (generic-function-methods gfun))) - (when (method-from-defgeneric-p m) + (when (getf (method-plist m) :method-from-defgeneric-p) (remove-method gfun m)))) (unless (classp method-class) (setf args (list* :method-class (find-class method-class) args))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 60718bbc0..1c7d225eb 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -127,9 +127,7 @@ (qualifiers :initform nil :initarg :qualifiers :accessor method-qualifiers) (function :initarg :function :accessor method-function) (documentation :initform nil :initarg documentation) - (declarations :initform nil) - (plist :initform nil :initarg :plist :accessor method-plist) - (from-defgeneric-p :initform nil :accessor method-from-defgeneric-p)))) + (plist :initform nil :initarg :plist :accessor method-plist)))) #.(create-accessors +standard-method-slots+ 'standard-method) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index c86d98468..cba3bc419 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -1322,6 +1322,8 @@ type_of(#0)==t_bitvector") (def-inline funcallable-standard-instance-access :always (funcallable-standard-object fixnum) t "instance_ref((#0),(#1))") (def-inline funcallable-standard-instance-access :unsafe (funcallable-standard-object fixnum) t "(#0)->instance.slots[#1]") + +(proclaim-function associate-methods-to-gfun (generic-function *) generic-function) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1386,7 +1388,10 @@ type_of(#0)==t_bitvector") #+clos (;; combin.lsp method-combination-error - invalid-method-error) + invalid-method-error + #-(or) standard-instance-access ; this function is a synonym for si:instance-ref + #-(or) funcallable-standard-instance-access ; same for this one + ) )) (proclaim @@ -1435,6 +1440,7 @@ type_of(#0)==t_bitvector") clos::method-qualifiers clos::method-function clos::method-plist + clos::associate-methods-to-gfun ;; method.lsp clos::pop-next-method )))