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.11 2007-11-08 13:49:26 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    boundp-function
  51    #+clisp(type :initarg :type :reader slot-definition-type)))
  52
  53 (defclass direct-special-slot-definition (standard-direct-slot-definition)
  54   ((special :initarg :special :accessor slot-definition-special)))
  55
  56 (defclass effective-special-slot-definition (standard-effective-slot-definition)
  57   ((special :initarg :special :accessor slot-definition-special)))
  58
  59 (defclass virtual-slots-object (standard-object)
  60   ())
  61
  62 (defgeneric slot-readable-p (slotd))
  63 (defgeneric slot-writable-p (slotd))
  64 (defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
  65 (defgeneric compute-slot-boundp-function (slotd))
  66 (defgeneric compute-slot-writer-function (slotd))
  67 (defgeneric compute-slot-makunbound-function (slotd))
  68
  69 (defmethod slot-readable-p ((slotd standard-effective-slot-definition))
  70   (declare (ignore slotd))
  71   t)
  72
  73 (defmethod slot-writable-p ((slotd standard-effective-slot-definition))
  74   (declare (ignore slotd))
  75   t)
  76
  77
  78 #+clisp
  79 (defmethod slot-definition-type ((slotd t))
  80   (clos:slot-definition-type slotd))
  81
  82
  83 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
  84   (cond
  85    ((eq (getf initargs :allocation) :virtual)
  86     (find-class 'direct-virtual-slot-definition))
  87    ((getf initargs :special)
  88     (find-class 'direct-special-slot-definition))
  89    (t (call-next-method))))
  90
  91 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
  92   (cond
  93    ((eq (getf initargs :allocation) :virtual)
  94     (find-class 'effective-virtual-slot-definition))
  95    ((getf initargs :special)
  96     (find-class 'effective-special-slot-definition))
  97    (t (call-next-method))))
  98
  99
 100 (defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
 101   (slot-boundp slotd 'getter))
 102
 103 (define-condition unreadable-slot (cell-error)
 104   ((instance :reader unreadable-slot-instance :initarg :instance))
 105   (:report (lambda (condition stream)
 106              (format stream "~@<The slot ~S in the object ~S is not readable.~@:>"
 107               (cell-error-name condition)
 108               (unreadable-slot-instance condition)))))
 109
 110 (defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
 111   (if (not (slot-readable-p slotd))
 112       #'(lambda (object)
 113           (error 'unreadable-slot :name (slot-definition-name slotd) :instance object))
 114     (let ((reader-function (call-next-method)))
 115       (cond
 116        ;; Don't create wrapper to signal unbound value
 117        ((not signal-unbound-p) reader-function)
 118
 119        ;; An explicit boundp function has been supplied
 120        ((slot-boundp slotd 'boundp)
 121         (let ((boundp (slot-value slotd 'boundp)))
 122           #'(lambda (object)
 123               (if (not (funcall boundp object))
 124                   (slot-unbound (class-of object) object (slot-definition-name slotd))
 125                 (funcall reader-function object)))))
 126
 127        ;; A type unbound value exists
 128        ((let ((unbound-method (find-applicable-type-method 'unbound-value
 129                                (slot-definition-type slotd) nil)))
 130           (when unbound-method
 131             (let ((unbound-value (funcall unbound-method (slot-definition-type slotd))))
 132               #'(lambda (object)
 133                   (let ((value (funcall reader-function object)))
 134                     (if (eq value unbound-value)
 135                         (slot-unbound (class-of object) object (slot-definition-name slotd))
 136                       value)))))))
 137
 138        ((let ((boundp-function (compute-slot-boundp-function slotd)))
 139           #'(lambda (object)
 140               (if (funcall boundp-function object)
 141                   (funcall reader-function object)
 142                 (slot-unbound (class-of object) object (slot-definition-name slotd))))))))))
 143
 144 (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
 145   (declare (ignore signal-unbound-p))
 146   (let ((getter (slot-value slotd 'getter)))
 147     #-sbcl getter
 148     #+sbcl
 149     (etypecase getter
 150       (symbol #'(lambda (object) (funcall getter object)))
 151       (function getter))))
 152
 153 (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
 154   (cond
 155    ;; Non readable slots are not bound per definition
 156    ((not (slot-readable-p slotd))
 157     #'(lambda (object) (declare (ignore object)) nil))
 158
 159    ;; An explicit boundp function has been supplied
 160    ((slot-boundp slotd 'boundp)
 161     (let ((boundp (slot-value slotd 'boundp)))
 162       #-sbcl boundp
 163       #+sbcl
 164       (etypecase boundp
 165         (symbol #'(lambda (object) (funcall boundp object)))
 166         (function boundp))))
 167
 168    ;; An unbound value has been supplied
 169    ((slot-boundp slotd 'unbound)
 170     (let ((reader-function (compute-slot-reader-function slotd nil))
 171           (unbound-value (slot-value slotd 'unbound)))
 172       #'(lambda (object)
 173           (not (eql (funcall reader-function object) unbound-value)))))
 174
 175    ;; A type unbound value exists
 176    ((let ((unbound-method (find-applicable-type-method 'unbound-value
 177                            (slot-definition-type slotd) nil)))
 178       (when unbound-method
 179         (let ((reader-function (compute-slot-reader-function slotd nil))
 180               (unbound-value (funcall unbound-method (slot-definition-type slotd))))
 181           #'(lambda (object)
 182               (not (eql (funcall reader-function object) unbound-value)))))))
 183
 184    ;; Slot has no unbound state
 185    (#'(lambda (object) (declare (ignore object)) t))))
 186
 187 (defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
 188   (slot-boundp slotd 'setter))
 189
 190 (define-condition unwritable-slot (cell-error)
 191   ((instance :reader unwritable-slot-instance :initarg :instance))
 192   (:report (lambda (condition stream)
 193              (format stream "~@<The slot ~S in the object ~S is not writable.~@:>"
 194               (cell-error-name condition)
 195               (unwritable-slot-instance condition)))))
 196
 197 (defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition))
 198   (if (not (slot-writable-p slotd))
 199       #'(lambda (value object)
 200           (declare (ignore value))
 201           (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))
 202     (call-next-method)))
 203
 204 (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
 205   (let ((setter (slot-value slotd 'setter)))
 206     #-sbcl setter
 207     #+sbcl
 208     (etypecase setter
 209       (symbol #'(lambda (value object) (funcall setter value object)))
 210       (list #'(lambda (value object)
 211                 (funcall setter value object)))
 212       (function setter))))
 213
 214 (define-condition slot-can-not-be-unbound (cell-error)
 215   ((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
 216   (:report (lambda (condition stream)
 217              (format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
 218               (cell-error-name condition)
 219               (slot-can-not-be-unbound-instance condition)))))
 220
 221 (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
 222   (cond
 223    ((not (slot-writable-p slotd))
 224     #'(lambda (object)
 225         (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
 226    ((slot-boundp slotd 'makunbound)
 227     (let ((makunbound (slot-value slotd 'makunbound)))
 228       #-sbcl makunbound
 229       #+sbcl
 230       (etypecase makunbound
 231         (symbol #'(lambda (object) (funcall makunbound object)))
 232         (function makunbound))))
 233    ((slot-boundp slotd 'unbound)
 234     #'(lambda (object)
 235         (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
 236    (t
 237     #'(lambda (object)
 238         (error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
 239
 240
 241 #-clisp
 242 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
 243   #?-(sbcl>= 0 9 8)
 244   (initialize-internal-slot-gfs (slot-definition-name slotd)))
 245
 246
 247 #-clisp
 248 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
 249   nil)
 250
 251
 252 (defun slot-bound-in-some-p (instances slot)
 253   (find-if
 254    #'(lambda (ob)
 255        (and (slot-exists-p ob slot) (slot-boundp ob slot)))
 256    instances))
 257
 258 (defun most-specific-slot-value (instances slot &optional default)
 259   (let ((object (slot-bound-in-some-p instances slot)))
 260     (if object
 261         (slot-value object slot)
 262       default)))
 263
 264 (defun compute-most-specific-initargs (slotds slots)
 265   (loop
 266    for slot in slots
 267    as (slot-name initarg) = (if (atom slot)
 268                                 (list slot (intern (string slot) "KEYWORD"))
 269                               slot)
 270    when (slot-bound-in-some-p slotds slot-name)
 271    nconc (list initarg (most-specific-slot-value slotds slot-name))))
 272
 273 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
 274   (typecase (first direct-slotds)
 275     (direct-virtual-slot-definition
 276      (nconc
 277       (compute-most-specific-initargs direct-slotds
 278        '(getter setter unbound boundp makunbound
 279          #?(or (sbcl>= 0 9 8) (featurep :clisp))
 280          (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
 281       (call-next-method)))
 282     (direct-special-slot-definition
 283      (append '(:special t) (call-next-method)))
 284     (t (call-next-method))))
 285
 286 (defmacro vsc-slot-x-using-class (x x-slot-name computer &key allow-string-fun-p)
 287   (let ((generic-name (intern (concatenate 'string
 288                                            "SLOT-" (string x) "-USING-CLASS"))))
 289     `(defmethod ,generic-name
 290          ((class virtual-slots-class) (object virtual-slots-object)
 291           (slotd effective-virtual-slot-definition))
 292        (unless (and (slot-boundp slotd ',x-slot-name)
 293                     ,@(when allow-string-fun-p
 294                          `((not
 295                             (stringp (slot-value slotd ',x-slot-name))))))
 296          (setf (slot-value slotd ',x-slot-name) (,computer slotd)))
 297        (funcall (slot-value slotd ',x-slot-name) object))))
 298
 299 (vsc-slot-x-using-class value getter compute-slot-reader-function
 300                         :allow-string-fun-p t)
 301 (vsc-slot-x-using-class boundp boundp-function compute-slot-boundp-function)
 302 (vsc-slot-x-using-class makunbound makunbound-function
 303                         compute-slot-makunbound-function)
 304
 305 (defmethod (setf slot-value-using-class) (value (class virtual-slots-class)
 306                                           (object virtual-slots-object)
 307                                           (slotd effective-virtual-slot-definition))
 308   (unless (slot-boundp slotd 'setter)
 309     (setf (slot-value slotd 'setter) (compute-slot-writer-function slotd)))
 310   (funcall (slot-value slotd 'setter) value object))
 311
 312 ;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
 313 ;; finalized when update-slots are called. So to avoid the possibility
 314 ;; of finalize-instance being called recursivly we have to delay the
 315 ;; initialization of slot functions until after an instance has been
 316 ;; created.
 317 ;; 2007-11-08: done this for all implementations
 318 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
 319 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
 320   (declare (ignore class))
 321   (setf (slot-value slotd name) (compute-slot-reader-function slotd)))
 322
 323 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
 324 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
 325   (declare (ignore class))
 326   (setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
 327
 328 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
 329 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
 330   (declare (ignore class))
 331   (setf (slot-value slotd name) (compute-slot-writer-function slotd)))
 332
 333 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
 334 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
 335   (declare (ignore class))
 336   (setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
 337
 338
 339 (defmethod validate-superclass
 340     ((class virtual-slots-class) (super standard-class))
 341   t)
 342
 343 (defmethod slot-definition-special ((slotd standard-direct-slot-definition))
 344   (declare (ignore slotd))
 345   nil)
 346
 347 (defmethod slot-definition-special ((slotd standard-effective-slot-definition))
 348   (declare (ignore slotd))
 349   nil)
 350
 351
 352 ;;; To determine if a slot should be initialized with the initform,
 353 ;;; CLISP checks whether it is unbound or not. This doesn't work with
 354 ;;; virtual slots that does not have an unbound state, so we have to
 355 ;;; implement initform initialization in a way similar to how it is
 356 ;;; done in PCL.
 357 #+clisp
 358 (defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
 359   (let* ((class (class-of object))
 360          (slotds (class-slots class))
 361          (keywords (loop
 362                     for args on initargs by #'cddr
 363                     collect (first args)))
 364          (names
 365           (loop
 366            for slotd in slotds
 367            as name = (slot-definition-name slotd)
 368            as initargs = (slot-definition-initargs slotd)
 369            as init-p = (and
 370                         (or (eq names t) (find name names))
 371                         (slot-definition-initfunction slotd)
 372                         (not (intersection initargs keywords)))
 373            as virtual-p = (typep slotd 'effective-virtual-slot-definition)
 374            when (and init-p virtual-p)
 375            do (setf
 376                (slot-value-using-class class object slotd)
 377                (funcall (slot-definition-initfunction slotd)))
 378            when (and init-p (not virtual-p))
 379            collect name)))
 380
 381       (apply #'call-next-method object names initargs)))