prototype of prototype specializers

Need to write some more tests, but I think the main thing that isn't
"right" is dealing with redefinitions

diff --git a/prototype-specializer.lisp b/prototype-specializer.lisp
new file mode 100644 (file)
index 0000000..4a2c841
--- /dev/null
+++ b/prototype-specializer.lisp
@@ -0,0 +1,197 @@
+(in-package "SPECIALIZABLE")
+
+(defclass prototype-object ()
+  (;; FIXME: we should add slots at some point
+   (delegations :initarg :delegations :accessor delegations)
+   (roles :initform (make-array 0 :adjustable t :fill-pointer t)
+          :accessor roles)
+   ;; debugging aid
+   (name)))
+(defmethod print-object ((o prototype-object) s)
+  (if (slot-boundp o 'name)
+      (format s "~S" (slot-value o 'name))
+      (print-unreadable-object (o s :type t :identity t)
+        (format s "[~{~S~^, ~}]" (delegations o)))))
+(defun add-delegation (obj del)
+  (push del (delegations obj)))
+(defun remove-delegation (obj)
+  (pop (delegations obj)))
+(defun map-delegations (fun obj)
+  (funcall fun obj)
+  ;; FIXME: should we maintain a table of visited nodes?  Should it be
+  ;; topologically sorted?  Section 5.3 in PwMD [Salzman & Aldrich]
+  ;; suggests not, at least for now
+  (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
+  nil)
+(defstruct (role (:type list) (:constructor make-role (method argpos)))
+  method argpos)
+(defun add-role (obj role)
+  (let ((pos (role-argpos role))
+        (roles (roles obj)))
+    (unless (< pos (length roles))
+      (dotimes (i (- (1+ pos) (length roles)))
+        (vector-push-extend nil roles)))
+    (pushnew (role-method role) (aref roles pos))))
+(defun remove-role (obj role)
+  (let ((pos (role-argpos role)))
+    (setf (aref (roles obj) pos)
+          (remove (role-method role) (aref (roles obj) pos)))
+    (tagbody
+     start
+       (when (or (= (length (roles obj)) 0)
+                 (aref (roles obj) (1- (length (roles obj)))))
+         (go done))
+       (vector-pop (roles obj))
+       (go start)
+     done)))
+(defun map-roles (fun obj)
+  (dotimes (i (length (roles obj)))
+    (dolist (m (aref (roles obj) i))
+      (funcall fun (make-role m i)))))
+(defun find-role (role obj)
+  (when (< (role-argpos role) (length (roles obj)))
+    (find (role-method role) (aref (roles obj) (role-argpos role)))))
+(defmacro do-roles ((rvar form &optional result) &body body)
+  `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
+(defun clone (p)
+  (let ((result (make-instance 'prototype-object
+                               :delegations (copy-list (delegations p)))))
+    (do-roles (r p result)
+      (add-role result r))))
+
+;;; redefinition semantics are interesting.  We need the INFO here so
+;;; that we can implement specializer-accepts-p, which must be able to
+;;; lookup the particular method/argpos that the specializer
+;;; represents.  But we must also be able to redefine methods in a way
+;;; that isn't insane, which I think implies that same-specializer-p
+;;; should ignore the INFO and just use the OBJECT.
+(defclass prototype-specializer (extended-specializer)
+  ((role :accessor prototype-specializer-role)
+   (object :initarg :object :accessor prototype-specializer-object)))
+(defmethod print-object ((o prototype-specializer) s)
+  (print-unreadable-object (o s :type t :identity t)
+    (format s "~S" (prototype-specializer-object o))))
+(defmethod sb-pcl::same-specializer-p
+    ((s1 prototype-specializer) (s2 prototype-specializer))
+  (eql (prototype-specializer-object s1)
+       (prototype-specializer-object s2)))
+(defclass prototype-generic-function (specializable-generic-function)
+  ()
+  (:metaclass sb-mop:funcallable-standard-class))
+(defmethod sb-pcl:make-method-specializers-form
+    ((gf prototype-generic-function) method snames env)
+  (flet ((frob (x)
+           (typecase x
+             (sb-mop:specializer x)
+             (symbol `(make-instance 'prototype-specializer :object ,x))
+             ((cons (eql 'class)) `(find-class ',(cadr x)))
+             ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
+             (t (error "unexpected specializer name: ~S" x)))))
+    `(list ,@(mapcar #'frob snames))))
+(defmethod sb-pcl:parse-specializer-using-class
+    ((gf prototype-generic-function) name)
+  (make-instance 'prototype-specializer :object name))
+(defmethod sb-pcl:unparse-specializer-using-class
+    ((gf prototype-generic-function) (s prototype-specializer))
+  (let ((object (prototype-specializer-object s)))
+    (if (slot-boundp object 'name)
+        (slot-value object 'name)
+        s)))
+
+(defmethod add-method :after ((gf prototype-generic-function) m)
+  (let ((ss (sb-mop:method-specializers m)))
+    (do* ((i 0 (1+ i))
+          (ss ss (cdr ss))
+          (s (car ss) (car ss)))
+         ((null ss))
+      (when (typep s 'prototype-specializer)
+        (let ((object (prototype-specializer-object s))
+              (role (make-role m i)))
+          (setf (prototype-specializer-role s) role)
+          (add-role object role))))))
+(defmethod remove-method :after ((gf prototype-generic-function) m)
+  (let ((ss (sb-mop:method-specializers m)))
+    (do* ((i 0 (1+ i))
+          (ss ss (cdr ss))
+          (s (car ss) (car ss)))
+         ((null ss))
+      (when (typep s 'prototype-specializer)
+        (let ((object (prototype-specializer-object s))
+              (role (make-role m i)))
+          (setf (prototype-specializer-role s) nil)
+          ;; this is one of the places where the semantics
+          ;; are... dodgy.  Removing the method from the generic
+          ;; function, and the role from the object, doesn't affect
+          ;; the roles in any clones.  We could potentially use the
+          ;; fact that once removed the method is no longer associated
+          ;; with a generic function?  Hm, C-A-M will not consider the
+          ;; removed method for applicability...
+          (remove-role object role))))))
+
+(defmethod generalizer-of-using-class
+    ((gf prototype-generic-function) (object prototype-object))
+  object)
+
+(defmethod specializer-accepts-generalizer-p
+    ((gf prototype-generic-function) (s prototype-specializer) object)
+  (values (specializer-accepts-p s object) t))
+
+(defmethod specializer-accepts-p ((specializer prototype-specializer) object)
+  (cond
+    ((not (typep object 'prototype-object)) nil)
+    ((eql (prototype-specializer-object specializer) /root/) t)
+    (t
+     (let ((role (prototype-specializer-role specializer)))
+       (map-delegations
+        (lambda (o)
+          (when (find-role role o)
+            (return-from specializer-accepts-p t)))
+        object)))))
+
+(defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
+  (let ((o1 (prototype-specializer-object s1))
+        (o2 (prototype-specializer-object s2)))
+    (map-delegations
+     (lambda (o)
+       (cond
+         ((eql o o1) (return-from specializer< '<))
+         ((eql o o2) (return-from specializer< '>))))
+     g)
+    '=))
+
+(defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
+  (values nil nil))
+(defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
+  g)
+
+(defmacro defpvar (name value)
+  `(let ((val ,value))
+     (setf (slot-value val 'name) ',name)
+     (defparameter ,name val)))
+
+(defpvar /root/ (make-instance 'prototype-object :delegations nil))
+(defpvar /animal/ (clone /root/))
+(defpvar /fish/ (clone /root/))
+(defpvar /shark/ (clone /root/))
+(defpvar /healthy-shark/ (clone /root/))
+(defpvar /dying-shark/ (clone /root/))
+(add-delegation /fish/ /animal/)
+(add-delegation /shark/ /animal/)
+(add-delegation /shark/ /healthy-shark/)
+(defgeneric encounter (x y)
+  (:generic-function-class prototype-generic-function))
+(defmethod encounter ((x /fish/) (y /healthy-shark/))
+  (format t "~&~A swims away~%" x))
+(defmethod encounter ((x /fish/) (y /animal/))
+  x)
+(defgeneric fight (x y)
+  (:generic-function-class prototype-generic-function))
+(defmethod fight ((x /healthy-shark/) (y /shark/))
+  (remove-delegation x)
+  (add-delegation x /dying-shark/)
+  x)
+(defmethod encounter ((x /healthy-shark/) (y /fish/))
+  (format t "~&~A swallows ~A~%" x y))
+(defmethod encounter ((x /healthy-shark/) (y /shark/))
+  (format t "~&~A fights ~A~%" x y)
+  (fight x y))