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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2005 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: proxy.lisp,v 1.23 2006-02-02 22:35:14 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
  28
  29 (eval-when (:compile-toplevel :load-toplevel :execute)
  30   (defclass virtual-slots-class (standard-class)
  31     ())
  32
  33   (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
  34     ((setter :reader slot-definition-setter :initarg :setter)
  35      (getter :reader slot-definition-getter :initarg :getter)
  36      (unbound :reader slot-definition-unbound :initarg :unbound)
  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      (unbound :reader slot-definition-unbound :initarg :unbound)
  43      (boundp :reader slot-definition-boundp :initarg :boundp)))
  44
  45   (defclass direct-special-slot-definition (standard-direct-slot-definition)
  46     ())
  47
  48   (defclass effective-special-slot-definition (standard-effective-slot-definition)
  49     ()))
  50
  51 (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
  52
  53 (defun most-specific-slot-value (instances slot &optional (default *unbound-marker*))
  54   (let ((object (find-if
  55                  #'(lambda (ob)
  56                      (and (slot-exists-p ob slot) (slot-boundp ob slot)))
  57                  instances)))
  58     (if object
  59         (slot-value object slot)
  60       default)))
  61
  62 (defmethod initialize-instance ((slotd effective-special-slot-definition) &rest initargs)
  63   (declare (ignore initargs))
  64   (call-next-method)
  65   (setf (slot-value slotd 'allocation) :instance))
  66
  67
  68 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
  69   (case (getf initargs :allocation)
  70     (:virtual (find-class 'direct-virtual-slot-definition))
  71     (:special (find-class 'direct-special-slot-definition))
  72     (t (call-next-method))))
  73
  74 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
  75   (case (getf initargs :allocation)
  76     (:virtual (find-class 'effective-virtual-slot-definition))
  77     (:special (find-class 'effective-special-slot-definition))
  78     (t (call-next-method))))
  79
  80
  81 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
  82   (if (not (slot-boundp slotd 'getter))
  83       (setf
  84        (slot-value slotd 'reader-function)
  85        #'(lambda (object)
  86            (declare (ignore object))
  87            (error "Can't read slot: ~A" (slot-definition-name slotd)))
  88        (slot-value slotd 'boundp-function)
  89        #'(lambda (object) (declare (ignore object)) nil))
  90
  91     (let ((getter-function
  92            (let ((getter (slot-value slotd 'getter)))
  93              (etypecase getter
  94                (function getter)
  95                (symbol
  96                 #'(lambda (object)
  97                     (funcall getter object)))
  98                (string
  99                 (let ((reader nil))
 100                   (setf (slot-value slotd 'reader-function)
 101                         #'(lambda (object)
 102                             (unless reader
 103                               (setq reader
 104                                (mkbinding getter
 105                                 (slot-definition-type slotd) 'pointer)))
 106                             (funcall reader (proxy-location object))))))))))
 107
 108       (setf
 109        (slot-value slotd 'boundp-function)
 110        (cond
 111         ((slot-boundp slotd 'unbound)
 112          (let ((unbound-value (slot-value slotd 'unbound)))
 113            #'(lambda (object)
 114                (not (eq (funcall getter-function object) unbound-value)))))
 115         ((slot-boundp slotd 'boundp)
 116          (let ((boundp (slot-value slotd 'boundp)))
 117            (etypecase boundp
 118              (function boundp)
 119              (symbol #'(lambda (object)
 120                          (funcall boundp object)))
 121              (string (let ((reader ()))
 122                        #'(lambda (object)
 123                            (unless reader
 124                              (setq reader
 125                               (mkbinding boundp
 126                                (slot-definition-type slotd) 'pointer)))
 127                            (funcall reader (proxy-location object))))))))
 128         ((multiple-value-bind (unbound-p unbound-value)
 129              (unbound-value (slot-definition-type slotd))
 130            (when unbound-p
 131              #'(lambda (object)
 132                  (not (eq (funcall getter-function object) unbound-value))))))
 133         (#'(lambda (object) (declare (ignore object)) t))))
 134
 135       (setf
 136        (slot-value slotd 'reader-function)
 137        (cond
 138         ((slot-boundp slotd 'unbound)
 139          (let ((unbound (slot-value slotd 'unbound))
 140                (slot-name (slot-definition-name slotd)))
 141            #'(lambda (object)
 142                (let ((value (funcall getter-function object)))
 143                  (if (eq value unbound)
 144                      (slot-unbound (class-of object) object slot-name)
 145                    value)))))
 146         ((slot-boundp slotd 'boundp)
 147          (let ((boundp-function (slot-value slotd 'boundp-function)))
 148            #'(lambda (object)
 149                (and
 150                 (funcall boundp-function object)
 151                 (funcall getter-function object)))))
 152         ((multiple-value-bind (unbound-p unbound-value)
 153              (unbound-value (slot-definition-type slotd))
 154            (let ((slot-name (slot-definition-name slotd)))
 155              (when unbound-p
 156                #'(lambda (object)
 157                    (let ((value (funcall getter-function object)))
 158                      (if (eq value unbound-value)
 159                          (slot-unbound (class-of object) object slot-name)
 160                          value)))))))
 161         (getter-function)))))
 162
 163   (setf
 164    (slot-value slotd 'writer-function)
 165    (if (not (slot-boundp slotd 'setter))
 166        #'(lambda (object)
 167            (declare (ignore object))
 168            (error "Can't set slot: ~A" (slot-definition-name slotd)))
 169      (with-slots (setter) slotd
 170        (etypecase setter
 171          (function setter)
 172          ((or symbol cons)
 173           #'(lambda (value object)
 174               (funcall (fdefinition setter) value object)))
 175          (string
 176           (let ((writer ()))
 177             (setf
 178              (slot-value slotd 'writer-function)
 179              #'(lambda (value object)
 180                  (unless writer
 181                    (setq writer
 182                     (mkbinding setter 'nil 'pointer
 183                      (slot-definition-type slotd))))
 184                  (funcall writer (proxy-location object) value)))))))))
 185
 186   (initialize-internal-slot-gfs (slot-definition-name slotd)))
 187
 188
 189
 190 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
 191   nil)
 192
 193 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
 194   (if (typep (first direct-slotds) 'direct-virtual-slot-definition)
 195       (let ((initargs ()))
 196         (let ((getter (most-specific-slot-value direct-slotds 'getter)))
 197           (unless (eq getter *unbound-marker*)
 198             (setf (getf initargs :getter) getter)))
 199         (let ((setter (most-specific-slot-value direct-slotds 'setter)))
 200           (unless (eq setter *unbound-marker*)
 201             (setf (getf initargs :setter) setter)))
 202         (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
 203           (unless (eq unbound *unbound-marker*)
 204             (setf (getf initargs :unbound) unbound)))
 205         (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
 206           (unless (eq boundp *unbound-marker*)
 207             (setf (getf initargs :boundp) boundp)))
 208         (nconc initargs (call-next-method)))
 209     (call-next-method)))
 210
 211
 212 (defmethod slot-value-using-class
 213     ((class virtual-slots-class) (object standard-object)
 214      (slotd effective-virtual-slot-definition))
 215   (if (funcall (slot-value slotd 'boundp-function) object)
 216       (funcall (slot-value slotd 'reader-function) object)
 217     (slot-unbound class object (slot-definition-name slotd))))
 218
 219 (defmethod slot-boundp-using-class
 220     ((class virtual-slots-class) (object standard-object)
 221      (slotd effective-virtual-slot-definition))
 222   (funcall (slot-value slotd 'boundp-function) object))
 223
 224 (defmethod (setf slot-value-using-class)
 225     (value (class virtual-slots-class) (object standard-object)
 226      (slotd effective-virtual-slot-definition))
 227   (funcall (slot-value slotd 'writer-function) value object))
 228
 229
 230 (defmethod validate-superclass
 231     ((class virtual-slots-class) (super standard-class))
 232   t)
 233
 234
 235 ;;;; Proxy cache
 236
 237 (internal *instance-cache*)
 238 (defvar *instance-cache* (make-hash-table :test #'eql))
 239
 240 (defun cache-instance (instance &optional (weak-ref t))
 241   (setf
 242    (gethash (sap-int (proxy-location instance)) *instance-cache*)
 243    (if weak-ref
 244        (make-weak-pointer instance)
 245      instance)))
 246
 247 (defun find-cached-instance (location)
 248   (let ((ref (gethash (sap-int location) *instance-cache*)))
 249     (when ref
 250       (if (weak-pointer-p ref)
 251           (weak-pointer-value ref)
 252         ref))))
 253
 254 (defun instance-cached-p (location)
 255   (gethash (sap-int location) *instance-cache*))
 256
 257 (defun remove-cached-instance (location)
 258   (remhash (sap-int location) *instance-cache*))
 259
 260 ;; For debuging
 261 (defun list-cached-instances ()
 262   (let ((instances ()))
 263     (maphash #'(lambda (location ref)
 264                  (declare (ignore location))
 265                  (push ref instances))
 266              *instance-cache*)
 267     instances))
 268
 269
 270
 271 ;;;; Proxy for alien instances
 272
 273 (defclass proxy ()
 274   ((location :allocation :special :reader proxy-location :type system-area-pointer))
 275   (:metaclass virtual-slots-class))
 276
 277 (defgeneric instance-finalizer (object))
 278 (defgeneric reference-foreign (class location))
 279 (defgeneric unreference-foreign (class location))
 280
 281 (defmethod reference-foreign ((name symbol) location)
 282   (reference-foreign (find-class name) location))
 283
 284 (defmethod unreference-foreign ((name symbol) location)
 285   (unreference-foreign (find-class name) location))
 286
 287 (defmethod unreference-foreign :around ((class class) location)
 288   (unless (null-pointer-p location)
 289 ;;     (format t "Unreferencing ~A at ~A" (class-name class) location)
 290 ;;     (finish-output *standard-output*)
 291     (call-next-method)
 292 ;;     (write-line " done")
 293 ;;     (finish-output *standard-output*)
 294     ))
 295
 296 (defmethod print-object ((instance proxy) stream)
 297   (print-unreadable-object (instance stream :type t :identity nil)
 298     (when (slot-boundp instance 'location)
 299       (format stream "at 0x~X" (sap-int (proxy-location instance))))))
 300
 301 (defmethod initialize-instance :around ((instance proxy) &key location)
 302   (if location
 303       (setf (slot-value instance 'location) location)
 304     (call-next-method))
 305   (cache-instance instance)
 306   (finalize instance (instance-finalizer instance))
 307   instance)
 308
 309 (defmethod instance-finalizer ((instance proxy))
 310   (let ((location (proxy-location instance))
 311         (class (class-of instance)))
 312 ;;     (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
 313 ;;       (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
 314     #'(lambda ()
 315         (remove-cached-instance location)
 316         (unreference-foreign class location))))
 317
 318
 319 ;;;; Metaclass used for subclasses of proxy
 320
 321 (defgeneric most-specific-proxy-superclass (class))
 322 (defgeneric direct-proxy-superclass (class))
 323
 324
 325 (eval-when (:compile-toplevel :load-toplevel :execute)
 326   (defclass proxy-class (virtual-slots-class)
 327     ((size :reader proxy-instance-size)))
 328
 329   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 330     ((allocation :initform :alien)
 331      (offset :reader slot-definition-offset :initarg :offset)))
 332
 333   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 334     ((offset :reader slot-definition-offset :initarg :offset)))
 335
 336   (defmethod most-specific-proxy-superclass ((class proxy-class))
 337     (find-if
 338      #'(lambda (class)
 339          (subtypep (class-name class) 'proxy))
 340      (cdr (compute-class-precedence-list class))))
 341
 342   (defmethod direct-proxy-superclass ((class proxy-class))
 343     (find-if
 344      #'(lambda (class)
 345          (subtypep (class-name class) 'proxy))
 346      (class-direct-superclasses class)))
 347
 348   (defmethod shared-initialize ((class proxy-class) names &key size)
 349     (call-next-method)
 350     (cond
 351       (size (setf (slot-value class 'size) (first size)))
 352       ((slot-boundp class 'size) (slot-makunbound class 'size))))
 353
 354   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
 355     (case (getf initargs :allocation)
 356       (:alien (find-class 'direct-alien-slot-definition))
 357       (t (call-next-method))))
 358
 359   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 360     (case (getf initargs :allocation)
 361       (:alien (find-class 'effective-alien-slot-definition))
 362       (t (call-next-method))))
 363
 364
 365   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
 366     (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
 367         (nconc
 368          (list :offset (most-specific-slot-value direct-slotds 'offset))
 369          (call-next-method))
 370       (call-next-method)))
 371
 372
 373   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
 374     (with-slots (offset) slotd
 375       (let ((type (slot-definition-type slotd)))
 376         (unless (slot-boundp slotd 'getter)
 377           (let ((reader (reader-function type)))
 378             (setf
 379              (slot-value slotd 'getter)
 380              #'(lambda (object)
 381                  (funcall reader (proxy-location object) offset)))))
 382
 383         (unless (slot-boundp slotd 'setter)
 384           (let ((writer (writer-function type))
 385                 (destroy (destroy-function type)))
 386             (setf
 387              (slot-value slotd 'setter)
 388              #'(lambda (value object)
 389                  (let ((location (proxy-location object)))
 390                    (funcall destroy location offset) ; destroy old value
 391                    (funcall writer value location offset))))))))
 392
 393     (call-next-method))
 394
 395
 396   ;; TODO: call some C code to detect this a compile time
 397   (defconstant +struct-alignmen+ 4)
 398
 399   (defmethod compute-slots ((class proxy-class))
 400     (loop
 401      with offset = (let ((size-of-super-classes
 402                           (proxy-instance-size
 403                            (most-specific-proxy-superclass class))))
 404                      (+ size-of-super-classes
 405                         (mod size-of-super-classes +struct-alignmen+)))
 406      with size = offset
 407      for slotd in (class-direct-slots class)
 408      when (eq (slot-definition-allocation slotd) :alien)
 409      do (if (not (slot-boundp slotd 'offset))
 410             (setf (slot-value slotd 'offset) offset)
 411           (setq offset (slot-value slotd 'offset)))
 412
 413         (incf offset (size-of (slot-definition-type slotd)))
 414         (incf offset (mod offset +struct-alignmen+))
 415         (setq size (max size offset))
 416
 417      finally (unless (slot-boundp class 'size)
 418                (setf (slot-value class 'size) size)))
 419     (call-next-method))
 420
 421
 422   (defmethod validate-superclass ((class proxy-class) (super standard-class))
 423     (subtypep (class-name super) 'proxy))
 424
 425   (defmethod proxy-instance-size (class)
 426     (declare (ignore class))
 427     0)
 428
 429   (defmethod proxy-instance-size ((class-name symbol))
 430     (proxy-instance-size (find-class class-name)))
 431 )
 432
 433 (defmethod alien-type ((class proxy-class) &rest args)
 434   (declare (ignore class args))
 435   (alien-type 'pointer))
 436
 437 (defmethod size-of ((class proxy-class) &rest args)
 438   (declare (ignore class args))
 439   (size-of 'pointer))
 440
 441 (defmethod from-alien-form (location (class proxy-class) &rest args)
 442   (declare (ignore args))
 443   `(ensure-proxy-instance ',(class-name class) ,location))
 444
 445 (defmethod from-alien-function ((class proxy-class) &rest args)
 446   (declare (ignore args))
 447   #'(lambda (location)
 448       (ensure-proxy-instance class location)))
 449
 450 (defmethod to-alien-form (instance (class proxy-class) &rest args)
 451   (declare (ignore class args))
 452   `(proxy-location ,instance))
 453
 454 (defmethod to-alien-function ((class proxy-class) &rest args)
 455   (declare (ignore class args))
 456   #'proxy-location)
 457
 458 (defmethod copy-from-alien-form (location (class proxy-class) &rest args)
 459   (declare (ignore args))
 460   (let ((class-name (class-name class)))
 461     `(ensure-proxy-instance ',class-name
 462       (reference-foreign ',class-name ,location))))
 463
 464 (defmethod copy-from-alien-function ((class proxy-class) &rest args)
 465   (declare (ignore args))
 466   #'(lambda (location)
 467       (ensure-proxy-instance class (reference-foreign class location))))
 468
 469 (defmethod copy-to-alien-form (instance (class proxy-class) &rest args)
 470   (declare (ignore args))
 471   `(reference-foreign ',(class-name class) (proxy-location ,instance)))
 472
 473 (defmethod copy-to-alien-function ((class proxy-class) &rest args)
 474   (declare (ignore args))
 475   #'(lambda (instance)
 476       (reference-foreign class (proxy-location instance))))
 477
 478 (defmethod writer-function ((class proxy-class) &rest args)
 479   (declare (ignore args))
 480   #'(lambda (instance location &optional (offset 0))
 481       (assert (null-pointer-p (sap-ref-sap location offset)))
 482       (setf
 483        (sap-ref-sap location offset)
 484        (reference-foreign class (proxy-location instance)))))
 485
 486 (defmethod reader-function ((class proxy-class) &rest args)
 487   (declare (ignore args))
 488   #'(lambda (location &optional (offset 0))
 489       (let ((instance (sap-ref-sap location offset)))
 490         (unless (null-pointer-p instance)
 491           (ensure-proxy-instance class (reference-foreign class instance))))))
 492
 493 (defmethod destroy-function ((class proxy-class) &rest args)
 494   (declare (ignore args))
 495   #'(lambda (location &optional (offset 0))
 496       (unreference-foreign class (sap-ref-sap location offset))))
 497
 498 (defmethod unbound-value ((class proxy-class) &rest args)
 499   (declare (ignore args))
 500   (values t nil))
 501
 502 (defgeneric ensure-proxy-instance (class location)
 503   (:documentation "Returns a proxy object representing the foreign object at the give location."))
 504
 505 (defmethod ensure-proxy-instance :around (class location)
 506   (unless (null-pointer-p location)
 507     (or
 508      (find-cached-instance location)
 509      (call-next-method))))
 510
 511 (defmethod ensure-proxy-instance ((class symbol) location)
 512   (ensure-proxy-instance (find-class class) location))
 513
 514 (defmethod ensure-proxy-instance ((class proxy-class) location)
 515   (make-instance class :location location))
 516
 517
 518 ;;;; Superclasses for wrapping of C structures
 519
 520 (defclass struct (proxy)
 521   ()
 522   (:metaclass proxy-class))
 523
 524 (defmethod initialize-instance ((struct struct) &rest initargs)
 525   (declare (ignore initargs))
 526   (unless (slot-boundp struct 'location)
 527     (let ((size (proxy-instance-size (class-of struct))))
 528       (if (zerop size)
 529           (error "~A has zero size" (class-of struct))
 530         (setf (slot-value struct 'location) (allocate-memory size)))))
 531   (call-next-method))
 532
 533
 534 ;;;; Metaclasses used for subclasses of struct
 535
 536 (defclass struct-class (proxy-class)
 537   ())
 538
 539 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
 540   (if (not (getf initargs :allocation))
 541       (find-class 'direct-alien-slot-definition)
 542     (call-next-method)))
 543
 544 (defmethod reference-foreign ((class struct-class) location)
 545   (copy-memory location (proxy-instance-size class)))
 546
 547 (defmethod unreference-foreign ((class struct-class) location)
 548   (deallocate-memory location))
 549
 550
 551 (defclass static-struct-class (struct-class)
 552   ())
 553
 554 (defmethod reference-foreign ((class static-struct-class) location)
 555   (declare (ignore class))
 556   location)
 557
 558 (defmethod unreference-foreign ((class static-struct-class) location)
 559   (declare (ignore class location))
 560   nil)
 561
 562
 563 ;;; Pseudo type for structs which are inlined in other objects
 564
 565 (defmethod size-of ((type (eql 'inlined)) &rest args)
 566   (declare (ignore type))
 567   (proxy-instance-size (first args)))
 568
 569 (defmethod reader-function ((type (eql 'inlined)) &rest args)
 570   (declare (ignore type))
 571   (destructuring-bind (class) args
 572     #'(lambda (location &optional (offset 0))
 573         (ensure-proxy-instance class
 574          (reference-foreign class (sap+ location offset))))))
 575
 576 (defmethod destroy-function ((type (eql 'inlined)) &rest args)
 577   (declare (ignore args))
 578   #'(lambda (location &optional (offset 0))
 579       (declare (ignore location offset))))
 580
 581 (export 'inlined)