examples/prototype-specializer.lisp

   1 (in-package "SPECIALIZABLE")
   2
   3 (defclass prototype-object ()
   4   (;; FIXME: we should add slots at some point
   5    (delegations :initarg :delegations :accessor delegations)
   6    (roles :initform (make-array 0 :adjustable t :fill-pointer t)
   7           :accessor roles)
   8    ;; debugging aid
   9    (name)))
  10 (defmethod print-object ((o prototype-object) s)
  11   (if (slot-boundp o 'name)
  12       (format s "~S" (slot-value o 'name))
  13       (print-unreadable-object (o s :type t :identity t)
  14         (format s "[~{~S~^, ~}]" (delegations o)))))
  15 (defun add-delegation (obj del)
  16   (push del (delegations obj)))
  17 (defun remove-delegation (obj)
  18   (pop (delegations obj)))
  19 (defun map-delegations (fun obj)
  20   (funcall fun obj)
  21   ;; FIXME: should we maintain a table of visited nodes?  Should it be
  22   ;; topologically sorted?  Section 5.3 in PwMD [Salzman & Aldrich]
  23   ;; suggests not, at least for now
  24   (mapc (lambda (o) (map-delegations fun o)) (delegations obj))
  25   nil)
  26 (defstruct (role (:type list) (:constructor make-role (method argpos)))
  27   method argpos)
  28 (defun add-role (obj role)
  29   (let ((pos (role-argpos role))
  30         (roles (roles obj)))
  31     (unless (< pos (length roles))
  32       (dotimes (i (- (1+ pos) (length roles)))
  33         (vector-push-extend nil roles)))
  34     (pushnew (role-method role) (aref roles pos))))
  35 (defun remove-role (obj role)
  36   (let ((pos (role-argpos role)))
  37     (setf (aref (roles obj) pos)
  38           (remove (role-method role) (aref (roles obj) pos)))
  39     (tagbody
  40      start
  41        (when (or (= (length (roles obj)) 0)
  42                  (aref (roles obj) (1- (length (roles obj)))))
  43          (go done))
  44        (vector-pop (roles obj))
  45        (go start)
  46      done)))
  47 (defun map-roles (fun obj)
  48   (dotimes (i (length (roles obj)))
  49     (dolist (m (aref (roles obj) i))
  50       (funcall fun (make-role m i)))))
  51 (defun find-role (role obj)
  52   (when (< (role-argpos role) (length (roles obj)))
  53     (find (role-method role) (aref (roles obj) (role-argpos role)))))
  54 (defmacro do-roles ((rvar form &optional result) &body body)
  55   `(progn (map-roles (lambda (,rvar) ,@body) ,form) ,result))
  56 (defun clone (p)
  57   (let ((result (make-instance 'prototype-object
  58                                :delegations (copy-list (delegations p)))))
  59     (do-roles (r p result)
  60       (add-role result r))))
  61
  62 ;;; redefinition semantics are interesting.  We need the INFO here so
  63 ;;; that we can implement specializer-accepts-p, which must be able to
  64 ;;; lookup the particular method/argpos that the specializer
  65 ;;; represents.  But we must also be able to redefine methods in a way
  66 ;;; that isn't insane, which I think implies that same-specializer-p
  67 ;;; should ignore the INFO and just use the OBJECT.
  68 (defclass prototype-specializer (extended-specializer)
  69   ((role :accessor prototype-specializer-role)
  70    (object :initarg :object :accessor prototype-specializer-object)))
  71 (defmethod print-object ((o prototype-specializer) s)
  72   (print-unreadable-object (o s :type t :identity t)
  73     (format s "~S" (prototype-specializer-object o))))
  74 (defmethod sb-pcl::same-specializer-p
  75     ((s1 prototype-specializer) (s2 prototype-specializer))
  76   (eql (prototype-specializer-object s1)
  77        (prototype-specializer-object s2)))
  78 (defclass prototype-generic-function (specializable-generic-function)
  79   ()
  80   (:metaclass sb-mop:funcallable-standard-class))
  81 (defmethod sb-pcl:make-method-specializers-form
  82     ((gf prototype-generic-function) method snames env)
  83   (flet ((frob (x)
  84            (typecase x
  85              (sb-mop:specializer x)
  86              (symbol `(make-instance 'prototype-specializer :object ,x))
  87              ((cons (eql 'class)) `(find-class ',(cadr x)))
  88              ((cons (eql 'eql)) `(sb-mop:intern-eql-specializer ,(cadr x)))
  89              (t (error "unexpected specializer name: ~S" x)))))
  90     `(list ,@(mapcar #'frob snames))))
  91 (defmethod sb-pcl:parse-specializer-using-class
  92     ((gf prototype-generic-function) name)
  93   (make-instance 'prototype-specializer :object name))
  94 (defmethod sb-pcl:unparse-specializer-using-class
  95     ((gf prototype-generic-function) (s prototype-specializer))
  96   (let ((object (prototype-specializer-object s)))
  97     (if (slot-boundp object 'name)
  98         (slot-value object 'name)
  99         s)))
 100
 101 (defmethod add-method :after ((gf prototype-generic-function) m)
 102   (let ((ss (sb-mop:method-specializers m)))
 103     (do* ((i 0 (1+ i))
 104           (ss ss (cdr ss))
 105           (s (car ss) (car ss)))
 106          ((null ss))
 107       (when (typep s 'prototype-specializer)
 108         (let ((object (prototype-specializer-object s))
 109               (role (make-role m i)))
 110           (setf (prototype-specializer-role s) role)
 111           (add-role object role))))))
 112 (defmethod remove-method :after ((gf prototype-generic-function) m)
 113   (let ((ss (sb-mop:method-specializers m)))
 114     (do* ((i 0 (1+ i))
 115           (ss ss (cdr ss))
 116           (s (car ss) (car ss)))
 117          ((null ss))
 118       (when (typep s 'prototype-specializer)
 119         (let ((object (prototype-specializer-object s))
 120               (role (make-role m i)))
 121           (setf (prototype-specializer-role s) nil)
 122           ;; this is one of the places where the semantics
 123           ;; are... dodgy.  Removing the method from the generic
 124           ;; function, and the role from the object, doesn't affect
 125           ;; the roles in any clones.  We could potentially use the
 126           ;; fact that once removed the method is no longer associated
 127           ;; with a generic function?  Hm, C-A-M will not consider the
 128           ;; removed method for applicability...
 129           (remove-role object role))))))
 130
 131 (defmethod generalizer-of-using-class
 132     ((gf prototype-generic-function) (object prototype-object))
 133   object)
 134
 135 (defmethod specializer-accepts-generalizer-p
 136     ((gf prototype-generic-function) (s prototype-specializer) object)
 137   (values (specializer-accepts-p s object) t))
 138
 139 (defmethod specializer-accepts-p ((specializer prototype-specializer) object)
 140   (cond
 141     ((not (typep object 'prototype-object)) nil)
 142     ((eql (prototype-specializer-object specializer) /root/) t)
 143     (t
 144      (let ((role (prototype-specializer-role specializer)))
 145        (map-delegations
 146         (lambda (o)
 147           (when (find-role role o)
 148             (return-from specializer-accepts-p t)))
 149         object)))))
 150
 151 (defmethod specializer< ((gf prototype-generic-function) (s1 prototype-specializer) (s2 prototype-specializer) g)
 152   (let ((o1 (prototype-specializer-object s1))
 153         (o2 (prototype-specializer-object s2)))
 154     (map-delegations
 155      (lambda (o)
 156        (cond
 157          ((eql o o1) (return-from specializer< '<))
 158          ((eql o o2) (return-from specializer< '>))))
 159      g)
 160     '=))
 161
 162 (defmethod compute-applicable-methods-using-generalizers ((gf prototype-generic-function) generalizers)
 163   (values nil nil))
 164 (defmethod generalizer-equal-hash-key ((gf prototype-generic-function) (g prototype-object))
 165   g)
 166
 167 (defmacro defpvar (name value)
 168   `(let ((val ,value))
 169      (setf (slot-value val 'name) ',name)
 170      (defparameter ,name val)))
 171
 172 (defpvar /root/ (make-instance 'prototype-object :delegations nil))
 173 (defpvar /animal/ (clone /root/))
 174 (defpvar /fish/ (clone /root/))
 175 (defpvar /shark/ (clone /root/))
 176 (defpvar /healthy-shark/ (clone /root/))
 177 (defpvar /dying-shark/ (clone /root/))
 178 (add-delegation /fish/ /animal/)
 179 (add-delegation /shark/ /animal/)
 180 (add-delegation /shark/ /healthy-shark/)
 181 (defgeneric encounter (x y)
 182   (:generic-function-class prototype-generic-function))
 183 (defmethod encounter ((x /fish/) (y /healthy-shark/))
 184   (format t "~&~A swims away~%" x))
 185 (defmethod encounter ((x /fish/) (y /animal/))
 186   x)
 187 (defgeneric fight (x y)
 188   (:generic-function-class prototype-generic-function))
 189 (defmethod fight ((x /healthy-shark/) (y /shark/))
 190   (remove-delegation x)
 191   (add-delegation x /dying-shark/)
 192   x)
 193 (defmethod encounter ((x /healthy-shark/) (y /fish/))
 194   (format t "~&~A swallows ~A~%" x y))
 195 (defmethod encounter ((x /healthy-shark/) (y /shark/))
 196   (format t "~&~A fights ~A~%" x y)
 197   (fight x y))