Plaster
New
List
Login
common-lisp
default
anonymous
2022.12.27 14:37:47
(defun goops-dispatch (gf args methods) (loop with nargs = (length args) for (method thunk) in methods for qualifiers = (cdr (method-qualifiers method)) for nqualifiers = (length qualifiers) when (= nargs nqualifiers) do (loop for arg in args for class-name in qualifiers for class = (find-class class-name) unless (typep arg class) do (return) finally (return-from goops-dispatch (funcall thunk))) finally (apply #'no-applicable-method gf args))) (define-method-combination goops-method-combination () ((goops (:goops . *)) (others *)) (:arguments &rest arguments) (:generic-function gf) (when others (invalid-method-error (car others) "Non-GOOPS method in GF.")) (let ((methods (mapcar (lambda (x) `(list ,x (lambda () (call-method ,x)))) goops))) `(goops-dispatch ,gf ,arguments (list ,@methods)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric foo (&rest args) (:method-combination goops-method-combination)) (defmethod foo :goops number number number (&rest args) (reduce #'+ args)) (defmethod foo :goops symbol (&rest args) (string-capitalize (symbol-name (first args)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CL-USER> (foo 1 2 3) 6 CL-USER> (foo :haha) "Haha" CL-USER> (ignore-errors (foo "nothing")) NIL #<SB-PCL::NO-APPLICABLE-METHOD-ERROR {100A45B753}>
Raw
Annotate
Repaste
Edit