Plaster
New
List
Login
common-lisp
default
anonymous
2022.12.27 19:43:27
(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload '(:alexandria :closer-mop :method-combination-utilities))) (defpackage #:goops-gf (:use #:cl) (:local-nicknames (#:a #:alexandria) (#:m #:closer-mop) (#:mcu #:method-combination-utilities))) (in-package #:goops-gf) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Method definition (defclass goops-method (m:standard-method) ((%goops-specializers :initarg :goops-specializers :reader goops-specializers))) (defmethod initialize-instance ((method goops-method) &rest args &key qualifiers) (let* ((class-names (cdr (member :goops qualifiers))) (classes (mapcar #'find-class class-names))) (apply #'call-next-method method :goops-specializers classes args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; GF class definition ;; TODO this probably warrants a redefinition lock somewhere to prevent races. (defclass goops-generic-function (m:standard-generic-function) ((%proxies :initarg :proxies :reader goops-gf-proxies) (%from-proxy :initarg :methods-from :reader goops-gf-from-proxy) (%to-proxy :initarg :methods-to :reader goops-gf-to-proxy)) (:default-initargs :proxies (make-array 0 :adjustable t :fill-pointer t) :methods-from (make-hash-table) :methods-to (make-hash-table) :method-combination (m:find-method-combination #'make-instance 'mcu:lax nil)) (:metaclass m:funcallable-standard-class)) (defmethod m:generic-function-method-class ((gf goops-generic-function)) (find-class 'goops-method)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Method proxying (defun ensure-proxy-count (gf nargs) (flet ((make-proxy (gf n) (make-instance 'standard-generic-function :lambda-list (a:make-gensym-list n) :declarations (m:generic-function-declarations gf) :method-combination (m:generic-function-method-combination gf) :name (a:symbolicate (m:generic-function-name gf) "-PROXY-" (prin1-to-string n))))) (let* ((proxies (goops-gf-proxies gf)) (nproxies (1- (length proxies)))) (loop for n from nproxies below nargs for proxy = (make-proxy gf (1+ n)) do (vector-push-extend proxy proxies) finally (return gf))))) (defmethod add-method ((gf goops-generic-function) (method goops-method)) (let* ((nargs (length (goops-specializers method)))) (ensure-proxy-count gf nargs) (let* ((proxy (elt (goops-gf-proxies gf) nargs)) (specializers (goops-specializers method)) (all-qualifiers (method-qualifiers method)) (qualifiers (subseq all-qualifiers 0 (position :goops all-qualifiers))) (proxy-function (m:method-function method)) (proxy-documentation (format nil "Proxy method for ~S with ~D args." gf nargs)) (proxy-method (make-instance 'standard-method :documentation proxy-documentation :function proxy-function :lambda-list (a:make-gensym-list nargs) :specializers specializers :qualifiers qualifiers)) (real-function (lambda (&rest args) (apply proxy-function args))) (real-documentation (format nil "Real method for ~S with ~D args." gf nargs)) (real-method (make-instance 'standard-method :documentation real-documentation :function real-function :lambda-list '(&rest args) :specializers '() :qualifiers all-qualifiers))) (setf (gethash real-method (goops-gf-to-proxy gf)) proxy-method (gethash proxy-method (goops-gf-from-proxy gf)) real-method) (add-method proxy proxy-method) (add-method gf real-method)))) (defmethod remove-method :before ((gf goops-generic-function) (real-method goops-method)) ;; Just clear the backlinks for now. (let* ((proxy-method (gethash real-method (goops-gf-to-proxy gf))) (proxy-gf (m:method-generic-function proxy-method))) (remove-method proxy-gf proxy-method) (remhash proxy-method (goops-gf-from-proxy gf)) (remhash real-method (goops-gf-to-proxy gf)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Applicable methods (defmethod compute-applicable-methods ((gf goops-generic-function) args) (let ((nargs (length args)) (max-nargs (1- (length (goops-gf-proxies gf))))) (if (< max-nargs nargs) '() (let ((proxy (elt (goops-gf-proxies gf) nargs))) (mapcar (lambda (x) (gethash x (goops-gf-from-proxy gf))) (compute-applicable-methods proxy args)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Discriminating function (defmethod m:compute-discriminating-function ((gf goops-generic-function)) (let* ((slots (m:class-slots (find-class 'goops-generic-function))) (slot (find '%proxies slots :key #'m:slot-definition-name)) (location (m:slot-definition-location slot))) (flet ((goops-dispatch (&rest args) (declare (optimize speed)) (let* ((nargs (length args)) (proxies (m:funcallable-standard-instance-access gf location)) (proxy (aref proxies nargs))) (declare (type (and (vector t) (not simple-array)) proxies)) (declare (type function proxy)) (apply proxy args)))) #'goops-dispatch))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Example code (progn (m:finalize-inheritance (find-class 'goops-method)) (m:finalize-inheritance (find-class 'goops-generic-function))) (defgeneric foo (&rest args) (:generic-function-class goops-generic-function)) (defmethod foo :goops (&rest args) (declare (ignore args)) :nothing) (defmethod foo :goops number (&rest args) (declare (ignore args)) :number) (defmethod foo :goops number number (&rest args) (declare (ignore args)) :two-numbers) (defmethod foo :goops ratio ratio (&rest args) (declare (ignore args)) :two-ratios) (defmethod foo :around :goops t t (&rest args) (declare (ignore args)) (list :around (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; REPL tests GOOPS-GF> (foo) :NOTHING GOOPS-GF> (foo 42) :NUMBER GOOPS-GF> (foo 42 42) (:AROUND :TWO-NUMBERS) GOOPS-GF> (foo 1/2 3/4) (:AROUND :TWO-RATIOS) GOOPS-GF> (compute-applicable-methods #'foo '()) (#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS () {1001B053B3}>) GOOPS-GF> (compute-applicable-methods #'foo '(1)) (#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER () {1001B053A3}>) GOOPS-GF> (compute-applicable-methods #'foo '(1 2)) (#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER NUMBER () {1001B05393}> #<STANDARD-METHOD GOOPS-GF::FOO :AROUND :GOOPS T T () {100565B773}>) GOOPS-GF> (compute-applicable-methods #'foo '(1/2 2/3)) (#<STANDARD-METHOD GOOPS-GF::FOO :GOOPS RATIO RATIO () {1001B05383}> #<STANDARD-METHOD GOOPS-GF::FOO :GOOPS NUMBER NUMBER () {1001B05393}> #<STANDARD-METHOD GOOPS-GF::FOO :AROUND :GOOPS T T () {100565B773}>)
Raw
Annotate
Repaste
Edit