chiark - git - mdw - clg/blob - glib/proxy.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: proxy.lisp,v 1.2 2001/04/30 11:25:25 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
  24
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (defclass virtual-class (pcl::standard-class))
  27
  28   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  29     ((location
  30       :reader slot-definition-location
  31       :initarg :location)))
  32
  33   (defclass effective-virtual-slot-definition
  34     (standard-effective-slot-definition)))
  35
  36
  37 (defmethod direct-slot-definition-class ((class virtual-class) initargs)
  38   (if (eq (getf initargs :allocation) :virtual)
  39       (find-class 'direct-virtual-slot-definition)
  40     (call-next-method)))
  41
  42
  43 (defmethod effective-slot-definition-class ((class virtual-class) initargs)
  44   (if (eq (getf initargs :allocation) :virtual)
  45       (find-class 'effective-virtual-slot-definition)
  46     (call-next-method)))
  47
  48
  49 (defun %direct-slot-definitions-slot-value (slotds slot &optional default)
  50   (let ((slotd
  51          (find-if
  52           #'(lambda (slotd)
  53               (and
  54                (slot-exists-p slotd slot)
  55                (slot-boundp slotd slot)))
  56           slotds)))
  57     (if slotd
  58         (slot-value slotd slot)
  59       default)))
  60
  61
  62 (defgeneric compute-virtual-slot-location (class slotd direct-slotds))
  63
  64 (defmethod compute-virtual-slot-location
  65     ((class virtual-class)
  66      (slotd effective-virtual-slot-definition)
  67      direct-slotds)
  68     (let ((location
  69            (%direct-slot-definitions-slot-value direct-slotds 'location)))
  70       (if (and location (symbolp location))
  71           (list location `(setf ,location))
  72         location)))
  73
  74
  75 (defmethod compute-effective-slot-definition
  76     ((class virtual-class) direct-slotds)
  77   (let ((slotd (call-next-method)))
  78     (when (typep slotd 'effective-virtual-slot-definition)
  79       (setf
  80        (slot-value slotd 'pcl::location)
  81        (compute-virtual-slot-location class slotd direct-slotds)))
  82     slotd))
  83
  84
  85 (defmethod slot-value-using-class
  86     ((class virtual-class) (object standard-object)
  87      (slotd effective-virtual-slot-definition))
  88   (let ((reader (first (slot-definition-location slotd))))
  89     (if reader
  90         (funcall reader object)
  91       (slot-unbound class object (slot-definition-name slotd)))))
  92
  93
  94 (defmethod slot-boundp-using-class
  95     ((class virtual-class) (object standard-object)
  96      (slotd effective-virtual-slot-definition))
  97    (and (first (slot-definition-location slotd)) t))
  98
  99
 100
 101 (defmethod (setf slot-value-using-class)
 102     (value (class virtual-class) (object standard-object)
 103      (slotd effective-virtual-slot-definition))
 104   (let ((writer (second (slot-definition-location slotd))))
 105     (cond
 106      ((null writer)
 107       (error
 108        "Can't set read-only slot ~A in ~A"
 109        (slot-definition-name slotd)
 110        object))
 111      ((or (functionp writer) (symbolp writer))
 112       (funcall writer value object)
 113       value)
 114      (t
 115       (funcall (fdefinition writer) value object)
 116       value))))
 117
 118
 119 (defmethod validate-superclass
 120     ((class virtual-class) (super pcl::standard-class))
 121   t)
 122
 123
 124 ;;;; Proxy cache
 125
 126 (internal *instance-cache*)
 127 (defvar *instance-cache* (make-hash-table :test #'eql))
 128
 129 (defun cache-instance (instance)
 130   (setf
 131    (gethash (system:sap-int (proxy-location instance)) *instance-cache*)
 132    (ext:make-weak-pointer instance)))
 133
 134 (defun find-cached-instance (location)
 135   (let ((ref (gethash (system:sap-int location) *instance-cache*)))
 136     (when ref
 137       (ext:weak-pointer-value ref))))
 138
 139 (defun remove-cached-instance (location)
 140   (remhash (system:sap-int location) *instance-cache*))
 141
 142
 143
 144 ;;;; Proxy for alien instances
 145
 146 (eval-when (:compile-toplevel :load-toplevel :execute)
 147   (defclass proxy ()
 148     ((location
 149       :reader proxy-location
 150       :type system-area-pointer)))
 151
 152   (defgeneric initialize-proxy (object &rest initargs))
 153   (defgeneric instance-finalizer (object)))
 154
 155
 156 (defmethod initialize-instance :after ((instance proxy)
 157                                        &rest initargs &key)
 158   (declare (ignore initargs))
 159   (cache-instance instance)
 160   (ext:finalize instance (instance-finalizer instance)))
 161
 162
 163 (defmethod initialize-proxy ((instance proxy)
 164                              &rest initargs)
 165   (declare (ignore initargs))
 166   (cache-instance instance))
 167
 168
 169 (defmethod instance-finalizer ((instance proxy))
 170   (let ((location (proxy-location instance)))
 171     #'(lambda ()
 172         (remove-cached-instance location))))
 173
 174
 175 (deftype-method translate-type-spec proxy (type-spec)
 176   (declare (ignore type-spec))
 177   (translate-type-spec 'pointer))
 178
 179 (deftype-method size-of proxy (type-spec)
 180   (declare (ignore type-spec))
 181   (size-of 'pointer))
 182
 183 (deftype-method translate-from-alien
 184     proxy (type-spec location &optional weak-ref)
 185   `(let ((location ,location))
 186      (unless (null-pointer-p location)
 187        (ensure-proxy-instance ',type-spec location ,weak-ref))))
 188
 189
 190
 191 ;;;; Metaclass used for subclasses of proxy
 192
 193 (eval-when (:compile-toplevel :load-toplevel :execute)
 194   (defclass proxy-class (virtual-class)
 195     ((size :reader proxy-class-instance-size)))
 196
 197   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 198     ((allocation
 199       :initform :alien)
 200      (offset
 201       :reader slot-definition-offset
 202       :initarg :offset
 203       :initform 0)))
 204
 205   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 206     ((offset :reader slot-definition-offset)))
 207
 208   (defclass effective-virtual-alien-slot-definition
 209     (effective-virtual-slot-definition))
 210
 211
 212   (defmethod most-specific-proxy-superclass ((class proxy-class))
 213     (find-if
 214      #'(lambda (class)
 215          (subtypep (class-name class) 'proxy))
 216      (cdr (pcl::compute-class-precedence-list class))))
 217
 218
 219   (defmethod shared-initialize ((class proxy-class) names
 220                                 &rest initargs &key size name)
 221     (declare (ignore initargs))
 222     (call-next-method)
 223     (when size
 224       (setf (slot-value class 'size) (first size))))
 225
 226
 227   (defmethod shared-initialize :after ((class proxy-class) names
 228                                        &rest initargs &key)
 229     (declare (ignore initargs names))
 230     (let* ((super (most-specific-proxy-superclass class))
 231            (actual-size
 232             (if (eq (class-name super) 'proxy)
 233                 0
 234               (proxy-class-instance-size super))))
 235       (dolist (slotd (class-slots class))
 236         (when (eq (slot-definition-allocation slotd) :alien)
 237           (with-slots (offset type) slotd
 238             (setq actual-size (max actual-size (+ offset (size-of type)))))))
 239       (cond
 240        ((not (slot-boundp class 'size))
 241         (setf (slot-value class 'size) actual-size))
 242        ((> actual-size (slot-value class 'size))
 243         (warn "The actual size of class ~A is lager than specified" class)))))
 244
 245
 246   (defmethod direct-slot-definition-class ((class proxy-class) initargs)
 247     (case (getf initargs :allocation)
 248       ((nil :alien) (find-class 'direct-alien-slot-definition))
 249 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
 250       (t (call-next-method))))
 251
 252
 253   (defmethod effective-slot-definition-class ((class proxy-class) initargs)
 254     (case (getf initargs :allocation)
 255       (:alien (find-class 'effective-alien-slot-definition))
 256       (:virtual (find-class 'effective-virtual-alien-slot-definition))
 257       (t (call-next-method))))
 258
 259
 260   (defmethod compute-virtual-slot-location
 261       ((class proxy-class) (slotd effective-alien-slot-definition)
 262        direct-slotds)
 263     (with-slots (offset type) slotd
 264       (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset))
 265       (let ((reader (intern-reader-function type))
 266             (writer (intern-writer-function type))
 267             (destroy (intern-destroy-function type)))
 268         (list
 269          #'(lambda (object)
 270              (funcall reader (proxy-location object) offset))
 271          #'(lambda (value object)
 272              (let ((location (proxy-location object)))
 273                (funcall destroy location offset)
 274                (funcall writer value location offset)))))))
 275
 276
 277   (defmethod compute-virtual-slot-location
 278       ((class proxy-class)
 279        (slotd effective-virtual-alien-slot-definition)
 280        direct-slotds)
 281     (let ((location (call-next-method))
 282           (class-name (class-name class)))
 283       (if (or (stringp location) (consp location))
 284           (destructuring-bind (reader &optional writer) (mklist location)
 285             (with-slots (type) slotd
 286               (list
 287                (if (stringp reader)
 288                    (mkbinding reader type class-name)
 289                  reader)
 290                (if (stringp writer)
 291                    (let ((writer (mkbinding writer 'nil class-name type)))
 292                      #'(lambda (value object)
 293                          (funcall writer object value)))
 294                  writer))))
 295         location)))
 296
 297
 298   (defmethod compute-slots ((class proxy-class))
 299     ;; Translating the user supplied relative (to previous slot) offsets
 300     ;; to absolute offsets.
 301     ;; This code is broken and have to be fixed.
 302     (with-slots (direct-slots) class
 303       (let* ((super (most-specific-proxy-superclass class))
 304              (slot-offset
 305               (if (eq (class-name super) 'proxy)
 306                   0
 307                 (proxy-class-instance-size super))))
 308         (dolist (slotd direct-slots)
 309           (when (eq (slot-definition-allocation slotd) :alien)
 310             (with-slots (offset type) slotd
 311               (setf
 312                offset (+ slot-offset offset)
 313                slot-offset (+ offset (size-of type)))))))
 314
 315       ;; Reverse the direct slot definitions so the effective slots
 316       ;; will be in correct order.
 317       (setf direct-slots (reverse direct-slots))
 318       ;; This nreverse caused me so much frustration that I leave it
 319       ;; here just as a reminder of what not to do.
 320 ;      (setf direct-slots (nreverse direct-slots))
 321       )
 322     (call-next-method))
 323
 324
 325   (defmethod validate-superclass ((class proxy-class)
 326                                   (super pcl::standard-class))
 327      (subtypep (class-name super) 'proxy))
 328
 329   (defgeneric make-proxy-instance (class location weak-ref &rest initargs &key)))
 330
 331
 332 (defmethod make-proxy-instance ((class symbol) location weak-ref
 333                                 &rest initargs &key)
 334   (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
 335
 336 (defmethod make-proxy-instance ((class proxy-class) location weak-ref
 337                                 &rest initargs &key)
 338   (let ((instance (allocate-instance class)))
 339     (apply
 340      #'initialize-proxy
 341      instance :location location :weak-ref weak-ref initargs)
 342     instance))
 343
 344 (defun ensure-proxy-instance (class location weak-ref &rest initargs)
 345   (or
 346    (find-cached-instance location)
 347    (apply #'make-proxy-instance class location weak-ref initargs)))
 348
 349
 350 ;;;; Superclass for wrapping of C structures
 351
 352 (eval-when (:compile-toplevel :load-toplevel :execute)
 353   (defclass alien-structure (proxy)
 354     ()
 355     (:metaclass proxy-class)
 356     (:size 0)))
 357
 358
 359 (defmethod initialize-instance ((structure alien-structure)
 360                                 &rest initargs)
 361   (declare (ignore initargs))
 362   (setf
 363    (slot-value structure 'location)
 364    (allocate-memory (proxy-class-instance-size (class-of structure))))
 365   (call-next-method))
 366
 367
 368 (defmethod initialize-proxy ((structure alien-structure)
 369                              &rest initargs &key location weak-ref)
 370   (declare (ignore initargs))
 371   (setf
 372    (slot-value structure 'location)
 373    (if weak-ref
 374        (copy-memory location (proxy-class-instance-size (class-of structure)))
 375      location))
 376   (call-next-method))
 377
 378
 379 (defmethod instance-finalizer ((structure alien-structure))
 380   (let ((location (proxy-location structure)))
 381     (declare (type system-area-pointer location))
 382     #'(lambda ()
 383         (deallocate-memory location)
 384         (remove-cached-instance location))))
 385
 386
 387 (deftype-method translate-to-alien
 388      alien-structure (type-spec object &optional weak-ref)
 389   (if weak-ref
 390       `(proxy-location ,object)
 391     `(copy-memory
 392       (proxy-location ,object)
 393       ,(proxy-class-instance-size (find-class type-spec)))))
 394
 395
 396 (deftype-method unreference-alien alien-structure (type-spec c-struct)
 397   (declare (ignore type-spec))
 398   `(deallocate-memory ,c-struct))