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.5 2001-05-29 15:43:44 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-slot-class (pcl::standard-class))
  27
  28   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  29     ((setter :reader slot-definition-setter :initarg :setter)
  30      (getter :reader slot-definition-getter :initarg :getter)))
  31
  32   (defclass effective-virtual-slot-definition
  33     (standard-effective-slot-definition)))
  34
  35
  36 (defmethod direct-slot-definition-class ((class virtual-slot-class) initargs)
  37   (if (eq (getf initargs :allocation) :virtual)
  38       (find-class 'direct-virtual-slot-definition)
  39     (call-next-method)))
  40
  41 (defmethod effective-slot-definition-class ((class virtual-slot-class) initargs)
  42   (if (eq (getf initargs :allocation) :virtual)
  43       (find-class 'effective-virtual-slot-definition)
  44     (call-next-method)))
  45
  46 (defun %most-specific-slot-value (slotds slot &optional default)
  47   (let ((slotd
  48          (find-if
  49           #'(lambda (slotd)
  50               (and
  51                (slot-exists-p slotd slot)
  52                (slot-boundp slotd slot)))
  53           slotds)))
  54     (if slotd
  55         (slot-value slotd slot)
  56       default)))
  57
  58 (defgeneric compute-virtual-slot-accessors (class slotd direct-slotds))
  59
  60 (defmethod compute-virtual-slot-accessors
  61     ((class virtual-slot-class)
  62      (slotd effective-virtual-slot-definition)
  63      direct-slotds)
  64     (let ((getter (%most-specific-slot-value direct-slotds 'getter))
  65           (setter (%most-specific-slot-value direct-slotds 'setter)))
  66       (list getter setter)))
  67
  68 (defmethod compute-effective-slot-definition
  69     ((class virtual-slot-class) direct-slotds)
  70   (let ((slotd (call-next-method)))
  71     (when (typep slotd 'effective-virtual-slot-definition)
  72       (setf
  73        (slot-value slotd 'pcl::location)
  74        (compute-virtual-slot-accessors class slotd direct-slotds)))
  75     slotd))
  76
  77 (defmethod slot-value-using-class
  78     ((class virtual-slot-class) (object standard-object)
  79      (slotd effective-virtual-slot-definition))
  80   (let ((reader (first (slot-definition-location slotd))))
  81     (if reader
  82         (funcall reader object)
  83       (slot-unbound class object (slot-definition-name slotd)))))
  84
  85 (defmethod slot-boundp-using-class
  86     ((class virtual-slot-class) (object standard-object)
  87      (slotd effective-virtual-slot-definition))
  88    (and (first (slot-definition-location slotd)) t))
  89
  90 (defmethod (setf slot-value-using-class)
  91     (value (class virtual-slot-class) (object standard-object)
  92      (slotd effective-virtual-slot-definition))
  93   (let ((setter (second (slot-definition-location slotd))))
  94     (cond
  95      ((null setter)
  96       (error
  97        "Can't set read-only slot ~A in ~A"
  98        (slot-definition-name slotd)
  99        object))
 100      ((or (functionp setter) (symbolp setter))
 101       (funcall setter value object)
 102       value)
 103      (t
 104       (funcall (fdefinition setter) value object)
 105       value))))
 106
 107 (defmethod validate-superclass
 108     ((class virtual-slot-class) (super pcl::standard-class))
 109   t)
 110
 111
 112 ;;;; Proxy cache
 113
 114 (internal *instance-cache*)
 115 (defvar *instance-cache* (make-hash-table :test #'eql))
 116
 117 (defun cache-instance (instance)
 118   (setf
 119    (gethash (system:sap-int (proxy-location instance)) *instance-cache*)
 120    (ext:make-weak-pointer instance)))
 121
 122 (defun find-cached-instance (location)
 123   (let ((ref (gethash (system:sap-int location) *instance-cache*)))
 124     (when ref
 125       (ext:weak-pointer-value ref))))
 126
 127 (defun remove-cached-instance (location)
 128   (remhash (system:sap-int location) *instance-cache*))
 129
 130
 131
 132 ;;;; Proxy for alien instances
 133
 134 (eval-when (:compile-toplevel :load-toplevel :execute)
 135   (defclass proxy ()
 136     ((location :reader proxy-location :type system-area-pointer)))
 137
 138   (defgeneric initialize-proxy (object &rest initargs))
 139   (defgeneric instance-finalizer (object)))
 140
 141
 142 (defmethod initialize-instance :after ((instance proxy)
 143                                        &rest initargs &key)
 144   (declare (ignore initargs))
 145   (cache-instance instance)
 146   (ext:finalize instance (instance-finalizer instance)))
 147
 148 (defmethod initialize-proxy ((instance proxy)
 149                              &rest initargs &key location weak-ref)
 150   (declare (ignore initargs))
 151   (setf
 152    (slot-value instance 'location)
 153    (if weak-ref
 154        (funcall
 155         (proxy-class-copy (class-of instance))
 156         (type-of instance) location)
 157      location))
 158   (cache-instance instance)
 159   (ext:finalize instance (instance-finalizer instance)))
 160
 161 (defmethod instance-finalizer ((instance proxy))
 162   (let ((free (proxy-class-free (class-of instance)))
 163         (type (type-of instance))
 164         (location (proxy-location instance)))
 165     (declare
 166      (type symbol type)
 167      (type system-area-pointer location))
 168     #'(lambda ()
 169         (funcall free type location)
 170         (remove-cached-instance location))))
 171
 172
 173 (deftype-method translate-type-spec proxy (type-spec)
 174   (declare (ignore type-spec))
 175   (translate-type-spec 'pointer))
 176
 177 (deftype-method size-of proxy (type-spec)
 178   (declare (ignore type-spec))
 179   (size-of 'pointer))
 180
 181 (deftype-method translate-from-alien
 182     proxy (type-spec location &optional weak-ref)
 183   `(let ((location ,location))
 184      (unless (null-pointer-p location)
 185        (ensure-proxy-instance ',type-spec location ,weak-ref))))
 186
 187 (deftype-method translate-to-alien
 188     proxy (type-spec instance &optional weak-ref)
 189   (if weak-ref
 190       `(proxy-location ,instance)
 191     `(funcall
 192       ',(proxy-class-copy (find-class type-spec))
 193       ',type-spec (proxy-location ,instance))))
 194
 195 (deftype-method unreference-alien proxy (type-spec location)
 196   `(funcall ',(proxy-class-free (find-class type-spec)) ',type-spec ,location))
 197
 198 (defun proxy-instance-size (proxy)
 199   (proxy-class-size (class-of proxy)))
 200
 201 ;;;; Metaclass used for subclasses of proxy
 202
 203 (eval-when (:compile-toplevel :load-toplevel :execute)
 204   (defclass proxy-class (virtual-slot-class)
 205     ((size :reader proxy-class-size)
 206      (copy :reader proxy-class-copy)
 207      (free :reader proxy-class-free)))
 208
 209   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 210     ((allocation :initform :alien)
 211      (offset :reader slot-definition-offset :initarg :offset)))
 212
 213   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 214     ((offset :reader slot-definition-offset)))
 215
 216   (defclass effective-virtual-alien-slot-definition
 217     (effective-virtual-slot-definition))
 218
 219
 220   (defmethod most-specific-proxy-superclass ((class proxy-class))
 221     (find-if
 222      #'(lambda (class)
 223          (subtypep (class-name class) 'proxy))
 224      (cdr (pcl::compute-class-precedence-list class))))
 225
 226   (defmethod direct-proxy-superclass ((class proxy-class))
 227     (find-if
 228      #'(lambda (class)
 229          (subtypep (class-name class) 'proxy))
 230      (pcl::class-direct-superclasses class)))
 231
 232   (defmethod shared-initialize ((class proxy-class) names
 233                                 &rest initargs &key size copy free)
 234     (declare (ignore initargs))
 235     (call-next-method)
 236     (cond
 237      (size (setf (slot-value class 'size) (first size)))
 238      ((slot-boundp class 'size) (slot-makunbound class 'size)))
 239     (cond
 240      (copy (setf (slot-value class 'copy) (first copy)))
 241      ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
 242     (cond
 243      (free (setf (slot-value class 'free) (first free)))
 244      ((slot-boundp class 'free) (slot-makunbound class 'free))))
 245
 246   (defmethod finalize-inheritance ((class proxy-class))
 247     (call-next-method)
 248     (let ((super (most-specific-proxy-superclass class)))
 249       (unless (or (not super) (eq super (find-class 'proxy)))
 250         (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
 251           (setf (slot-value class 'copy) (proxy-class-copy super)))
 252         (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
 253           (setf (slot-value class 'free) (proxy-class-free super))))))
 254
 255   (defmethod direct-slot-definition-class ((class proxy-class) initargs)
 256     (case (getf initargs :allocation)
 257       ((nil :alien) (find-class 'direct-alien-slot-definition))
 258 ;      (:instance (error "Allocation :instance not allowed in class ~A" class))
 259       (t (call-next-method))))
 260
 261   (defmethod effective-slot-definition-class ((class proxy-class) initargs)
 262     (case (getf initargs :allocation)
 263       (:alien (find-class 'effective-alien-slot-definition))
 264       (:virtual (find-class 'effective-virtual-alien-slot-definition))
 265       (t (call-next-method))))
 266
 267   (defmethod compute-virtual-slot-accessors
 268       ((class proxy-class) (slotd effective-alien-slot-definition)
 269        direct-slotds)
 270     (with-slots (offset type) slotd
 271       (let ((reader (intern-reader-function type))
 272             (writer (intern-writer-function type))
 273             (destroy (intern-destroy-function type)))
 274         (setf offset (slot-definition-offset (first direct-slotds)))
 275         (list
 276          #'(lambda (object)
 277              (funcall reader (proxy-location object) offset))
 278          #'(lambda (value object)
 279              (let ((location (proxy-location object)))
 280                (funcall destroy location offset)
 281                (funcall writer value location offset)))))))
 282
 283   (defmethod compute-virtual-slot-accessors
 284       ((class proxy-class)
 285        (slotd effective-virtual-alien-slot-definition)
 286        direct-slotds)
 287     (destructuring-bind (getter setter) (call-next-method)
 288       (let ((class-name (class-name class)))
 289         (with-slots (type) slotd
 290           (list
 291            (if (stringp getter)
 292                (mkbinding getter type class-name)
 293              getter)
 294            (if (stringp setter)
 295                (let ((setter (mkbinding setter 'nil class-name type)))
 296                  #'(lambda (value object)
 297                      (funcall setter object value)))
 298              setter))))))
 299
 300   (defmethod compute-slots ((class proxy-class))
 301     (with-slots (direct-slots size) class
 302       (let ((current-offset
 303              (proxy-class-size (most-specific-proxy-superclass class)))
 304             (max-size 0))
 305         (dolist (slotd direct-slots)
 306           (when (eq (slot-definition-allocation slotd) :alien)
 307             (with-slots (offset type) slotd
 308               (unless (slot-boundp slotd 'offset)
 309                 (setf offset current-offset))
 310               (setq current-offset (+ offset (size-of type)))
 311               (setq max-size (max max-size current-offset)))))
 312         (unless (slot-boundp class 'size)
 313           (setf size max-size))))
 314     (call-next-method))
 315
 316   (defmethod validate-superclass ((class proxy-class)
 317                                   (super pcl::standard-class))
 318     (subtypep (class-name super) 'proxy))
 319
 320   (defmethod proxy-class-size (class)
 321     (declare (ignore class))
 322     0)
 323
 324   (defgeneric make-proxy-instance (class location weak-ref
 325                                    &rest initargs &key)))
 326
 327 (defmethod make-proxy-instance ((class symbol) location weak-ref
 328                                 &rest initargs &key)
 329   (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
 330
 331 (defmethod make-proxy-instance ((class proxy-class) location weak-ref
 332                                 &rest initargs &key)
 333   (let ((instance (allocate-instance class)))
 334     (apply
 335      #'initialize-proxy
 336      instance :location location :weak-ref weak-ref initargs)
 337     instance))
 338
 339 (defun ensure-proxy-instance (class location weak-ref &rest initargs)
 340   (or
 341    (find-cached-instance location)
 342    (apply #'make-proxy-instance class location weak-ref initargs)))
 343
 344
 345
 346 ;;;; Superclasses for wrapping of C structures
 347
 348 (eval-when (:compile-toplevel :load-toplevel :execute)
 349   (defclass struct (proxy)
 350     ()
 351     (:metaclass proxy-class)
 352     (:copy %copy-struct)
 353     (:free %free-struct)))
 354
 355 (defmethod initialize-instance ((structure struct)
 356                                 &rest initargs)
 357   (declare (ignore initargs))
 358   (setf
 359    (slot-value structure 'location)
 360    (allocate-memory (proxy-class-size (class-of structure))))
 361   (call-next-method))
 362
 363
 364 (defun %copy-struct (type location)
 365   (copy-memory location (proxy-class-size (find-class type))))
 366
 367 (defun %free-struct (type location)
 368   (declare (ignore type))
 369   (deallocate-memory location))
 370
 371
 372 ;(eval-when (:compile-toplevel :load-toplevel :execute)
 373   (defclass static (struct)
 374     ()
 375     (:metaclass proxy-class)
 376     (:copy %copy-static)
 377     (:free %free-static));)
 378
 379 (defun %copy-static (type location)
 380   (declare (ignore type))
 381   location)
 382
 383 (defun %free-static (type location)
 384   (declare (ignore type location))
 385   nil)