Hi!
Based on the information on method initialization in the MOP
documentation, I wrote a simple implementation of defmethod using
#'make-method-lambda, #'add-method etc.:
(defun normalized-argument (specialized-argument)
(if (atom specialized-argument) (list specialized-argument t)
specialized-argument))
(defun split-special-arguments (args)
(when args
(if (member (car args) '(&rest &key &optional)) (values nil args)
(multiple-value-bind
(basic special)
(split-special-arguments (cdr args))
(values (cons (car args) basic) special)))))
(defun specializers (args)
(mapcar
#'(lambda (specializer)
(if (atom specializer) (find-class specializer)
(intern-eql-specializer (cadr specializer))))
(mapcar #'cadr
(mapcar #'normalized-argument
(split-special-arguments args)))))
(defun unspecialized (args)
(multiple-value-bind
(basic special)
(split-special-arguments args)
(concatenate 'list
(mapcar #'car (mapcar #'normalized-argument basic))
special)))
(defmacro defmethod
(name &rest definition &environment context)
(let* ((qualifiers
(when (atom (car definition)) (list (car definition))))
(at-args (if qualifiers (cdr definition) definition))
(args (car at-args))
(body (cdr at-args))
(generic (ensure-generic-function name))
(method (gensym)))
(multiple-value-bind
(method-lambda initializers)
(make-method-lambda generic
(class-prototype
(generic-function-method-class generic))
`(lambda ,args ,@body) context)
`(let ((,method
(apply #'make-instance
(generic-function-method-class ,generic)
:qualifiers ',qualifiers :specializers
(specializers ',args) :lambda-list
(unspecialized ',args) :function
#',method-lambda ',initializers)))
(add-method ,generic ,method)
,method))))
For sure, it does not handle all the possible defmethod
invocations. But it already handles many basic cases. However,
dispatching multi-methods notably fails on the implementations I could
test it on (sbcl and gcl compiled in ANSI mode). This can be verified
using the following test code:
(defclass foo nil ((foo :initarg foo)))
(defclass bar nil ((bar :initarg bar)))
(defgeneric baz (x y))
(defmethod baz ((x foo) (y bar))
(list (slot-value x 'foo) (slot-value y 'bar)))
(baz (make-instance 'foo 'foo 1) (make-instance 'bar 'bar 2))
The last form should evaluate to (1 2), but both implementations error
out somewhere inside pcl::pv-table-lookup-pv-args. Is there something
wrong in my defmethod implementation regarding this? Is there a free
CLOS implementation with MOP out there that is not based on PCL, so I
can test the code on it?
Thanks in advance
Isidor Zeuner