+(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))
projects / specializable.git / blobdiff