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.6 2001-10-21 16:55:39 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                (let ((getter (mkbinding-late getter type 'pointer)))
 293                  #'(lambda (object)
 294                      (funcall getter (proxy-location object))))
 295              getter)
 296            (if (stringp setter)
 297                (let ((setter (mkbinding-late setter 'nil 'pointer type)))
 298                  #'(lambda (value object)
 299                      (funcall setter (proxy-location object) value)))
 300              setter))))))
 301
 302   (defmethod compute-slots ((class proxy-class))
 303     (with-slots (direct-slots size) class
 304       (let ((current-offset
 305              (proxy-class-size (most-specific-proxy-superclass class)))
 306             (max-size 0))
 307         (dolist (slotd direct-slots)
 308           (when (eq (slot-definition-allocation slotd) :alien)
 309             (with-slots (offset type) slotd
 310               (unless (slot-boundp slotd 'offset)
 311                 (setf offset current-offset))
 312               (setq current-offset (+ offset (size-of type)))
 313               (setq max-size (max max-size current-offset)))))
 314         (unless (slot-boundp class 'size)
 315           (setf size max-size))))
 316     (call-next-method))
 317
 318   (defmethod validate-superclass ((class proxy-class)
 319                                   (super pcl::standard-class))
 320     (subtypep (class-name super) 'proxy))
 321
 322   (defmethod proxy-class-size (class)
 323     (declare (ignore class))
 324     0)
 325
 326   (defgeneric make-proxy-instance (class location weak-ref
 327                                    &rest initargs &key)))
 328
 329 (defmethod make-proxy-instance ((class symbol) location weak-ref
 330                                 &rest initargs &key)
 331   (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
 332
 333 (defmethod make-proxy-instance ((class proxy-class) location weak-ref
 334                                 &rest initargs &key)
 335   (let ((instance (allocate-instance class)))
 336     (apply
 337      #'initialize-proxy
 338      instance :location location :weak-ref weak-ref initargs)
 339     instance))
 340
 341 (defun ensure-proxy-instance (class location weak-ref &rest initargs)
 342   (or
 343    (find-cached-instance location)
 344    (apply #'make-proxy-instance class location weak-ref initargs)))
 345
 346
 347
 348 ;;;; Superclasses for wrapping of C structures
 349
 350 (eval-when (:compile-toplevel :load-toplevel :execute)
 351   (defclass struct (proxy)
 352     ()
 353     (:metaclass proxy-class)
 354     (:copy %copy-struct)
 355     (:free %free-struct)))
 356
 357 (defmethod initialize-instance ((structure struct)
 358                                 &rest initargs)
 359   (declare (ignore initargs))
 360   (setf
 361    (slot-value structure 'location)
 362    (allocate-memory (proxy-class-size (class-of structure))))
 363   (call-next-method))
 364
 365
 366 (defun %copy-struct (type location)
 367   (copy-memory location (proxy-class-size (find-class type))))
 368
 369 (defun %free-struct (type location)
 370   (declare (ignore type))
 371   (deallocate-memory location))
 372
 373
 374 ;(eval-when (:compile-toplevel :load-toplevel :execute)
 375   (defclass static (struct)
 376     ()
 377     (:metaclass proxy-class)
 378     (:copy %copy-static)
 379     (:free %free-static));)
 380
 381 (defun %copy-static (type location)
 382   (declare (ignore type))
 383   location)
 384
 385 (defun %free-static (type location)
 386   (declare (ignore type location))
 387   nil)