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