(required-portion gf args)))
(emfun (gethash generalizers (emf-table gf) nil)))
(if emfun
- (funcall emfun args)
+ (sb-pcl::invoke-emf emfun args)
(slow-method-lookup gf args generalizers)))))
(defun slow-method-lookup (gf args generalizers)
(let* ((emfun
(compute-effective-method-function gf applicable-methods)))
(setf (gethash generalizers (emf-table gf)) emfun)
- (funcall emfun args))
- (funcall (compute-effective-method-function
- gf (sb-mop:compute-applicable-methods gf args))
- args))))
+ (sb-pcl::invoke-emf emfun args))
+ (sb-pcl::invoke-emf (compute-effective-method-function
+ gf (sb-mop:compute-applicable-methods gf args))
+ args))))
+
+(defun compute-effective-method-function (gf methods)
+ (let* ((mc (sb-mop:generic-function-method-combination gf))
+ (em (sb-mop:compute-effective-method gf mc methods)))
+ (sb-pcl::make-effective-method-function gf em)))
;; new, not in closette
(defgeneric generalizer-of-using-class (generic-function object))
(defmethod specializer< ((c1 class) (c2 sb-mop:eql-specializer) generalizer)
(declare (ignore generalizer))
'>)
-\f
-;;;; method combination
-
-;;; FIXME: this is actually only standard method combination.
-
-;; unchanged from closette
-(defun primary-method-p (method)
- (null (method-qualifiers method)))
-(defun before-method-p (method)
- (equal '(:before) (method-qualifiers method)))
-(defun after-method-p (method)
- (equal '(:after) (method-qualifiers method)))
-(defun around-method-p (method)
- (equal '(:around) (method-qualifiers method)))
-
-;;; (defun compute-effective-method-function (gf methods)
-;;; (let ((primaries (remove-if-not #'primary-method-p methods))
-;;; (around (find-if #'around-method-p methods)))
-;;; (when (null primaries)
-;;; (error "No primary methods for the~@
-;;; generic function ~S." gf))
-;;; (if around
-;;; (let ((next-emfun
-;;; (compute-effective-method-function gf (remove around methods))))
-;;; #'(lambda (args)
-;;; (funcall (method-function around) args next-emfun)))
-;;; (let ((next-emfun (compute-primary-emfun (cdr primaries)))
-;;; (befores (remove-if-not #'before-method-p methods))
-;;; (reverse-afters
-;;; (reverse (remove-if-not #'after-method-p methods))))
-;;; #'(lambda (args)
-;;; (dolist (before befores)
-;;; (funcall (method-function before) args nil))
-;;; (multiple-value-prog1
-;;; (funcall (method-function (car primaries)) args next-emfun)
-;;; (dolist (after reverse-afters)
-;;; (funcall (method-function after) args nil))))))))
-
-(defun compute-effective-method-function (gf methods)
- (let* ((primaries
- (or (remove-if-not #'primary-method-p methods)
- (error "No primary methods for the generic function ~S." gf)))
- (primary-emf
- (let* ((nexts (mapcar #'sb-mop:method-function (cdr primaries)))
- (befores (remove-if-not #'before-method-p methods))
- (reverse-afters
- (reverse (remove-if-not #'after-method-p methods))))
- #'(lambda (args)
- (dolist (before befores)
- (funcall (sb-mop:method-function before) args nil))
- (multiple-value-prog1
- (funcall (sb-mop:method-function (car primaries))
- args
- nexts)
- (dolist (after reverse-afters)
- (funcall (sb-mop:method-function after) args nil))))))
- (arounds (remove-if-not #'around-method-p methods)))
- (if arounds
- (let ((next (append (mapcar #'sb-mop:method-function (cdr arounds))
- (lambda (args nexts)
- (declare (ignore nexts))
- (funcall primary-emf args)))))
- (lambda (args)
- (funcall (sb-mop:method-function (car arounds))
- args
- next)))
- primary-emf)))
-\f
-;;;; example
-(defclass cons-specializer (extended-specializer)
- ((car :initarg :car :reader %car)))
-(defclass cons-generic-function (specializable-generic-function)
- ()
- (:metaclass sb-mop:funcallable-standard-class))
-
-(define-extended-specializer cons (gf car)
- (make-instance 'cons-specializer :car car))
-
-(defmethod sb-pcl:unparse-specializer-using-class
- ((gf cons-generic-function) (specializer cons-specializer))
- `(cons ,(%car specializer)))
-(defmethod sb-pcl::same-specializer-p
- ((s1 cons-specializer) (s2 cons-specializer))
- (eql (%car s1) (%car s2)))
-
-(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
- (typecase arg
- ((cons symbol) (car arg))
- (t (call-next-method))))
-;;; FIXME: it looks like these protocol functions should have the GF
-;;; as an argument, since generalizer-of-using-class does
-(defmethod specializer-accepts-generalizer-p ((specializer cons-specializer) thing)
- (if (eql (%car specializer) thing)
- (values t t)
- (values nil t)))
-;;; FIXME: yes, definitely need the gf!
-(defmethod specializer-accepts-generalizer-p (specializer (thing symbol))
- (specializer-accepts-generalizer-p specializer (find-class 'cons)))
-
-(defmethod specializer-accepts-p ((specializer cons-specializer) obj)
- (and (consp obj)
- (eql (car obj) (%car specializer))))
-(defmethod specializer< ((s1 cons-specializer) (s2 cons-specializer) generalizer)
- (declare (ignore generalizer))
- (if (eql (%car s1) (%car s2))
- '=
- nil))
-(defmethod specializer< ((s1 cons-specializer) (s2 class) generalizer)
- (declare (ignore generalizer))
- '<)
-(defmethod specializer< ((s1 cons-specializer) (s2 sb-mop:eql-specializer) generalizer)
- (declare (ignore generalizer))
- '>)
-(defmethod specializer< ((s1 sb-mop:specializer) (s2 cons-specializer) generalizer)
- (ecase (specializer< s2 s1 generalizer)
- ((<) '>)
- ((>) '<)))
-
-(defgeneric walk (form)
- (:generic-function-class cons-generic-function))
-
-(defmethod walk ((form symbol))
- `(lookup ,form))
-(defmethod walk ((form cons))
- `(call (flookup ,(car form)) (list ,@(mapcar #'walk (cdr form)))))
-(defmethod walk ((form (cons quote)))
- (cadr form))
-(defmethod walk ((form (cons let)))
- (let ((bindings (cadr form)))
- `(with-bindings ,bindings ,@(cddr form))))
projects / specializable.git / blobdiff