chiark - git - mdw - clg/blob - gffi/virtual-slots.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: virtual-slots.lisp,v 1.2 2006/08/16 11:02:45 espen Exp $
  24
  25 (in-package "GFFI")
  26
  27 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
  28
  29 (defclass virtual-slots-class (standard-class)
  30   ())
  31
  32 (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  33   ((setter :reader slot-definition-setter :initarg :setter)
  34    (getter :reader slot-definition-getter :initarg :getter)
  35    (unbound :reader slot-definition-unbound :initarg :unbound)
  36    (boundp :reader slot-definition-boundp :initarg :boundp)
  37    (makunbound :reader slot-definition-makunbound :initarg :makunbound)
  38    #+clisp(type :initarg :type :reader slot-definition-type)))
  39
  40 (defclass effective-virtual-slot-definition (standard-effective-slot-definition)
  41   ((setter :reader slot-definition-setter :initarg :setter)
  42    (getter :reader slot-definition-getter :initarg :getter)
  43    (unbound :reader slot-definition-unbound :initarg :unbound)
  44    (boundp :reader slot-definition-boundp :initarg :boundp)
  45    (makunbound :reader slot-definition-makunbound :initarg :makunbound)
  46    #+clisp(reader-function)
  47    #+clisp(writer-function)
  48    #+clisp(boundp-function)
  49    makunbound-function
  50    #+clisp(type :initarg :type :reader slot-definition-type)))
  51
  52 (defclass direct-special-slot-definition (standard-direct-slot-definition)
  53   ((special :initarg :special :accessor slot-definition-special)))
  54
  55 (defclass effective-special-slot-definition (standard-effective-slot-definition)
  56   ((special :initarg :special :accessor slot-definition-special)))
  57
  58 (defclass virtual-slots-object (standard-object)
  59   ())
  60
  61
  62 (defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
  63 (defgeneric compute-slot-boundp-function (slotd))
  64 (defgeneric compute-slot-writer-function (slotd))
  65 (defgeneric compute-slot-makunbound-function (slotd))
  66
  67
  68 #+clisp
  69 (defmethod slot-definition-type ((slotd t))
  70   (clos:slot-definition-type slotd))
  71
  72
  73 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
  74   (cond
  75    ((eq (getf initargs :allocation) :virtual)
  76     (find-class 'direct-virtual-slot-definition))
  77    ((getf initargs :special)
  78     (find-class 'direct-special-slot-definition))
  79    (t (call-next-method))))
  80
  81 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
  82   (cond
  83    ((eq (getf initargs :allocation) :virtual)
  84     (find-class 'effective-virtual-slot-definition))
  85    ((getf initargs :special)
  86     (find-class 'effective-special-slot-definition))
  87    (t (call-next-method))))
  88
  89
  90 (define-condition unreadable-slot (cell-error)
  91   ((instance :reader unreadable-slot-instance :initarg :instance))
  92   (:report (lambda (condition stream)
  93              (format stream "~@<The slot ~S in the object ~S is not readable.~@:>"
  94               (cell-error-name condition)
  95               (unreadable-slot-instance condition)))))
  96
  97 (defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
  98   (let ((reader-function (call-next-method)))
  99     (cond
 100      ((not signal-unbound-p) reader-function)
 101
 102      ;; An explicit boundp function has been supplied
 103      ((slot-boundp slotd 'boundp)
 104       (let ((unbound-value (slot-value slotd 'boundp)))
 105         #'(lambda (object)
 106             (let ((value (funcall reader-function object)))
 107               (if (eq value unbound-value)
 108                   (slot-unbound (class-of object) object (slot-definition-name slotd))
 109                 value)))))
 110
 111      ;; A type unbound value exists
 112      ((let ((unbound-method (find-applicable-type-method 'unbound-value
 113                              (slot-definition-type slotd) nil)))
 114         (when unbound-method
 115           (let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
 116             #'(lambda (object)
 117                 (let ((value (funcall reader-function object)))
 118                   (if (eq value unbound-value)
 119                       (slot-unbound (class-of object) object (slot-definition-name slotd))
 120                     value)))))))
 121
 122      ((let ((boundp-function (compute-slot-boundp-function slotd)))
 123         #'(lambda (object)
 124             (if (funcall boundp-function object)
 125                 (funcall reader-function object)
 126               (slot-unbound (class-of object) object (slot-definition-name slotd)))))))))
 127
 128 (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
 129   (declare (ignore signal-unbound-p))
 130   (if (slot-boundp slotd 'getter)
 131       (slot-value slotd 'getter)
 132     #'(lambda (object)
 133         (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))))
 134
 135 (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
 136   (cond
 137    ;; An explicit boundp function has been supplied
 138    ((slot-boundp slotd 'boundp) (slot-value slotd 'boundp))
 139
 140    ;; An unbound value has been supplied
 141    ((slot-boundp slotd 'unbound)
 142     (let ((reader-function (compute-slot-reader-function slotd nil))
 143           (unbound-value (slot-value slotd 'unbound)))
 144       #'(lambda (object)
 145           (not (eql (funcall reader-function object) unbound-value)))))
 146
 147    ;; A type unbound value exists
 148    ((let ((unbound-method (find-applicable-type-method 'unbound-value
 149                            (slot-definition-type slotd) nil)))
 150       (when unbound-method
 151         (let ((reader-function (compute-slot-reader-function slotd nil))
 152               (unbound-value (funcall unbound-method (slot-definition-type slotd))))
 153           #'(lambda (object)
 154               (not (eql (funcall reader-function object) unbound-value)))))))
 155
 156    ;; Slot has no unbound state
 157    (#'(lambda (object) (declare (ignore object)) t))))
 158
 159 (define-condition unwritable-slot (cell-error)
 160   ((instance :reader unwritable-slot-instance :initarg :instance))
 161   (:report (lambda (condition stream)
 162              (format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
 163               (cell-error-name condition)
 164               (unwritable-slot-instance condition)))))
 165
 166 (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
 167   (if (slot-boundp slotd 'setter)
 168       (slot-value slotd 'setter)
 169     #'(lambda (value object)
 170         (declare (ignore value))
 171         (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))))
 172
 173 (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
 174   (cond
 175    ((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound))
 176    ((slot-boundp slotd 'unbound)
 177     #'(lambda (object)
 178         (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
 179    (t
 180     #'(lambda (object)
 181         (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))))
 182
 183
 184 #-clisp
 185 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
 186   #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
 187   (setf
 188    (slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
 189    (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)
 190    (slot-value slotd 'writer-function) (compute-slot-writer-function slotd)
 191    (slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd))
 192
 193   #?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd)))
 194
 195
 196 #-clisp
 197 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
 198   nil)
 199
 200
 201 (defun slot-bound-in-some-p (instances slot)
 202   (find-if
 203    #'(lambda (ob)
 204        (and (slot-exists-p ob slot) (slot-boundp ob slot)))
 205    instances))
 206
 207 (defun most-specific-slot-value (instances slot &optional default)
 208   (let ((object (slot-bound-in-some-p instances slot)))
 209     (if object
 210         (slot-value object slot)
 211       default)))
 212
 213 (defun compute-most-specific-initargs (slotds slots)
 214   (loop
 215    for slot in slots
 216    as (slot-name initarg) = (if (atom slot)
 217                                 (list slot (intern (string slot) "KEYWORD"))
 218                               slot)
 219    when (slot-bound-in-some-p slotds slot-name)
 220    nconc (list initarg (most-specific-slot-value slotds slot-name))))
 221
 222 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
 223   (typecase (first direct-slotds)
 224     (direct-virtual-slot-definition
 225      (nconc
 226       (compute-most-specific-initargs direct-slotds
 227        '(getter setter unbound boundp makunbound
 228          #?(or (sbcl>= 0 9 8) (featurep :clisp))
 229          (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
 230       (call-next-method)))
 231     (direct-special-slot-definition
 232      (append '(:special t) (call-next-method)))
 233     (t (call-next-method))))
 234
 235 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
 236 (defmethod slot-value-using-class
 237     ((class virtual-slots-class) (object virtual-slots-object)
 238      (slotd effective-virtual-slot-definition))
 239     (funcall (slot-value slotd 'reader-function) object))
 240
 241 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
 242 (defmethod slot-boundp-using-class
 243     ((class virtual-slots-class) (object virtual-slots-object)
 244      (slotd effective-virtual-slot-definition))
 245     (funcall (slot-value slotd 'boundp-function) object))
 246
 247 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
 248 (defmethod (setf slot-value-using-class)
 249     (value (class virtual-slots-class) (object virtual-slots-object)
 250      (slotd effective-virtual-slot-definition))
 251   (funcall (slot-value slotd 'writer-function) value object))
 252
 253 (defmethod slot-makunbound-using-class
 254     ((class virtual-slots-class) (object virtual-slots-object)
 255      (slotd effective-virtual-slot-definition))
 256   (funcall (slot-value slotd 'makunbound-function) object))
 257
 258
 259 ;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
 260 ;; finalized when update-slots are called. So to avoid the possibility
 261 ;; of finalize-instance beeing called recursivly we have to delay the
 262 ;; initialization of slot functions until after an instance has been
 263 ;; created.
 264 #?(or (sbcl>= 0 9 15) (featurep :clisp))
 265 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
 266   (setf (slot-value slotd name) (compute-slot-reader-function slotd)))
 267
 268 #?(or (sbcl>= 0 9 15) (featurep :clisp))
 269 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
 270   (setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
 271
 272 #?(or (sbcl>= 0 9 15) (featurep :clisp))
 273 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
 274   (setf (slot-value slotd name) (compute-slot-writer-function slotd)))
 275
 276 #?(or (sbcl>= 0 9 15) (featurep :clisp))
 277 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
 278   (setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
 279
 280
 281 (defmethod validate-superclass
 282     ((class virtual-slots-class) (super standard-class))
 283   t)
 284
 285 (defmethod slot-definition-special ((slotd standard-direct-slot-definition))
 286   (declare (ignore slotd))
 287   nil)
 288
 289 (defmethod slot-definition-special ((slotd standard-effective-slot-definition))
 290   (declare (ignore slotd))
 291   nil)
 292
 293
 294 ;;; To determine if a slot should be initialized with the initform,
 295 ;;; CLISP checks whether it is unbound or not. This doesn't work with
 296 ;;; virtual slots which does not have an unbound state, so we have to
 297 ;;; implement initform initialization in a way similar to how it is
 298 ;;; done in PCL.
 299 #+clisp
 300 (defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
 301   (let* ((class (class-of object))
 302          (slotds (class-slots class))
 303          (keywords (loop
 304                     for args on initargs by #'cddr
 305                     collect (first args)))
 306          (names
 307           (loop
 308            for slotd in slotds
 309            as name = (slot-definition-name slotd)
 310            as initargs = (slot-definition-initargs slotd)
 311            as init-p = (and
 312                         (or (eq names t) (find name names))
 313                         (slot-definition-initfunction slotd)
 314                         (not (intersection initargs keywords)))
 315            as virtual-p = (typep slotd 'effective-virtual-slot-definition)
 316            when (and init-p virtual-p)
 317            do (setf
 318                (slot-value-using-class class object slotd)
 319                (funcall (slot-definition-initfunction slotd)))
 320            when (and init-p (not virtual-p))
 321            collect name)))
 322
 323       (apply #'call-next-method object names initargs)))