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.24 2006-02-04 12:15:32 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 (foreign-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 (foreign-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 (foreign-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 (foreign-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 foreign-location :type 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     (call-next-method)))
 290
 291 (defmethod print-object ((instance proxy) stream)
 292   (print-unreadable-object (instance stream :type t :identity nil)
 293     (if (slot-boundp instance 'location)
 294         (format stream "at 0x~X" (sap-int (foreign-location instance)))
 295       (write-string "at \"unbound\"" stream))))
 296
 297 (defmethod initialize-instance :around ((instance proxy) &key location)
 298   (if location
 299       (setf (slot-value instance 'location) location)
 300     (call-next-method))
 301   (cache-instance instance)
 302   (finalize instance (instance-finalizer instance))
 303   instance)
 304
 305 (defmethod instance-finalizer ((instance proxy))
 306   (let ((location (foreign-location instance))
 307         (class (class-of instance)))
 308 ;;     (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
 309 ;;       (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
 310     #'(lambda ()
 311         (remove-cached-instance location)
 312         (unreference-foreign class location))))
 313
 314
 315 ;;;; Metaclass used for subclasses of proxy
 316
 317 (defgeneric most-specific-proxy-superclass (class))
 318 (defgeneric direct-proxy-superclass (class))
 319 (defgeneric compute-foreign-size (class))
 320
 321
 322 (eval-when (:compile-toplevel :load-toplevel :execute)
 323   (defclass proxy-class (virtual-slots-class)
 324     ((size :reader foreign-size)))
 325
 326   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 327     ((allocation :initform :alien)
 328      (offset :reader slot-definition-offset :initarg :offset)))
 329
 330   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 331     ((offset :reader slot-definition-offset :initarg :offset)))
 332
 333   (defmethod most-specific-proxy-superclass ((class proxy-class))
 334     (find-if
 335      #'(lambda (class)
 336          (subtypep (class-name class) 'proxy))
 337      (cdr (compute-class-precedence-list class))))
 338
 339   (defmethod direct-proxy-superclass ((class proxy-class))
 340     (find-if
 341      #'(lambda (class)
 342          (subtypep (class-name class) 'proxy))
 343      (class-direct-superclasses class)))
 344
 345   (defmethod shared-initialize ((class proxy-class) names &key size)
 346     (call-next-method)
 347     (cond
 348       (size (setf (slot-value class 'size) (first size)))
 349       ((slot-boundp class 'size) (slot-makunbound class 'size))))
 350
 351   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
 352     (case (getf initargs :allocation)
 353       (:alien (find-class 'direct-alien-slot-definition))
 354       (t (call-next-method))))
 355
 356   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 357     (case (getf initargs :allocation)
 358       (:alien (find-class 'effective-alien-slot-definition))
 359       (t (call-next-method))))
 360
 361
 362   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
 363     (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
 364         (nconc
 365          (list :offset (most-specific-slot-value direct-slotds 'offset))
 366          (call-next-method))
 367       (call-next-method)))
 368
 369
 370   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
 371     (with-slots (offset) slotd
 372       (let ((type (slot-definition-type slotd)))
 373         (unless (slot-boundp slotd 'getter)
 374           (let ((reader (reader-function type)))
 375             (setf
 376              (slot-value slotd 'getter)
 377              #'(lambda (object)
 378                  (funcall reader (foreign-location object) offset)))))
 379
 380         (unless (slot-boundp slotd 'setter)
 381           (let ((writer (writer-function type))
 382                 (destroy (destroy-function type)))
 383             (setf
 384              (slot-value slotd 'setter)
 385              #'(lambda (value object)
 386                  (let ((location (foreign-location object)))
 387                    (funcall destroy location offset) ; destroy old value
 388                    (funcall writer value location offset))))))))
 389
 390     (call-next-method))
 391
 392   (defmethod compute-foreign-size ((class proxy-class))
 393     nil)
 394
 395   ;; TODO: call some C code to detect this a compile time
 396   (defconstant +struct-alignmen+ 4)
 397
 398   (defun align-offset (size)
 399     (if (zerop (mod size +struct-alignmen+))
 400         size
 401       (+ size (- +struct-alignmen+ (mod size +struct-alignmen+)))))
 402
 403   (defmethod compute-slots ((class proxy-class))
 404     (let ((alien-slots
 405            (remove-if-not
 406             #'(lambda (slotd)
 407                 (eq (slot-definition-allocation slotd) :alien))
 408             (class-direct-slots class))))
 409       (when alien-slots
 410         (loop
 411          as offset = (align-offset (foreign-size
 412                                     (most-specific-proxy-superclass class)))
 413                      then (align-offset
 414                            (+
 415                             (slot-definition-offset slotd)
 416                             (size-of (slot-definition-type slotd))))
 417        for slotd in alien-slots
 418        unless (slot-boundp slotd 'offset)
 419        do (setf (slot-value slotd 'offset) offset))))
 420     (call-next-method))
 421
 422   (defmethod compute-slots :after ((class proxy-class))
 423     (when (and (class-finalized-p class) (not (slot-boundp class 'size)))
 424       (let ((size (compute-foreign-size class)))
 425         (when size
 426           (setf (slot-value class 'size) size)))))
 427
 428   (defmethod validate-superclass ((class proxy-class) (super standard-class))
 429     (subtypep (class-name super) 'proxy))
 430
 431   (defmethod foreign-size ((class-name symbol))
 432     (foreign-size (find-class class-name))))
 433
 434 (defmethod foreign-size ((object proxy))
 435   (foreign-size (class-of object)))
 436
 437
 438 (defmethod alien-type ((class proxy-class) &rest args)
 439   (declare (ignore class args))
 440   (alien-type 'pointer))
 441
 442 (defmethod size-of ((class proxy-class) &rest args)
 443   (declare (ignore class args))
 444   (size-of 'pointer))
 445
 446 (defmethod from-alien-form (location (class proxy-class) &rest args)
 447   (declare (ignore args))
 448   `(ensure-proxy-instance ',(class-name class) ,location))
 449
 450 (defmethod from-alien-function ((class proxy-class) &rest args)
 451   (declare (ignore args))
 452   #'(lambda (location)
 453       (ensure-proxy-instance class location)))
 454
 455 (defmethod to-alien-form (instance (class proxy-class) &rest args)
 456   (declare (ignore class args))
 457   `(foreign-location ,instance))
 458
 459 (defmethod to-alien-function ((class proxy-class) &rest args)
 460   (declare (ignore class args))
 461   #'foreign-location)
 462
 463 (defmethod copy-from-alien-form (location (class proxy-class) &rest args)
 464   (declare (ignore args))
 465   (let ((class-name (class-name class)))
 466     `(ensure-proxy-instance ',class-name
 467       (reference-foreign ',class-name ,location))))
 468
 469 (defmethod copy-from-alien-function ((class proxy-class) &rest args)
 470   (declare (ignore args))
 471   #'(lambda (location)
 472       (ensure-proxy-instance class (reference-foreign class location))))
 473
 474 (defmethod copy-to-alien-form (instance (class proxy-class) &rest args)
 475   (declare (ignore args))
 476   `(reference-foreign ',(class-name class) (foreign-location ,instance)))
 477
 478 (defmethod copy-to-alien-function ((class proxy-class) &rest args)
 479   (declare (ignore args))
 480   #'(lambda (instance)
 481       (reference-foreign class (foreign-location instance))))
 482
 483 (defmethod writer-function ((class proxy-class) &rest args)
 484   (declare (ignore args))
 485   #'(lambda (instance location &optional (offset 0))
 486       (assert (null-pointer-p (sap-ref-sap location offset)))
 487       (setf
 488        (sap-ref-sap location offset)
 489        (reference-foreign class (foreign-location instance)))))
 490
 491 (defmethod reader-function ((class proxy-class) &rest args)
 492   (declare (ignore args))
 493   #'(lambda (location &optional (offset 0))
 494       (let ((instance (sap-ref-sap location offset)))
 495         (unless (null-pointer-p instance)
 496           (ensure-proxy-instance class (reference-foreign class instance))))))
 497
 498 (defmethod destroy-function ((class proxy-class) &rest args)
 499   (declare (ignore args))
 500   #'(lambda (location &optional (offset 0))
 501       (unreference-foreign class (sap-ref-sap location offset))))
 502
 503 (defmethod unbound-value ((class proxy-class) &rest args)
 504   (declare (ignore args))
 505   (values t nil))
 506
 507 (defgeneric ensure-proxy-instance (class location)
 508   (:documentation "Returns a proxy object representing the foreign object at the give location."))
 509
 510 (defmethod ensure-proxy-instance :around (class location)
 511   (unless (null-pointer-p location)
 512     (or
 513      (find-cached-instance location)
 514      (call-next-method))))
 515
 516 (defmethod ensure-proxy-instance ((class symbol) location)
 517   (ensure-proxy-instance (find-class class) location))
 518
 519 (defmethod ensure-proxy-instance ((class proxy-class) location)
 520   (make-instance class :location location))
 521
 522
 523 ;;;; Superclasses for wrapping of C structures
 524
 525 (defclass struct (proxy)
 526   ()
 527   (:metaclass proxy-class)
 528   (:size 0))
 529
 530 (defmethod initialize-instance ((struct struct) &rest initargs)
 531   (declare (ignore initargs))
 532   (unless (slot-boundp struct 'location)
 533     (let ((size (foreign-size (class-of struct))))
 534       (if (zerop size)
 535           (error "~A has zero size" (class-of struct))
 536         (setf (slot-value struct 'location) (allocate-memory size)))))
 537   (call-next-method))
 538
 539
 540 ;;;; Metaclasses used for subclasses of struct
 541
 542 (defclass struct-class (proxy-class)
 543   ())
 544
 545 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
 546   (if (not (getf initargs :allocation))
 547       (find-class 'direct-alien-slot-definition)
 548     (call-next-method)))
 549
 550 (defmethod reference-foreign ((class struct-class) location)
 551   (copy-memory location (foreign-size class)))
 552
 553 (defmethod unreference-foreign ((class struct-class) location)
 554   (deallocate-memory location))
 555
 556 (defmethod compute-foreign-size ((class struct-class))
 557   (let ((size (loop
 558                for slotd in (class-slots class)
 559                when (eq (slot-definition-allocation slotd) :alien)
 560                maximize (+
 561                          (slot-definition-offset slotd)
 562                          (size-of (slot-definition-type slotd))))))
 563     (+ size (mod size +struct-alignmen+))))
 564
 565
 566 (defclass static-struct-class (struct-class)
 567   ())
 568
 569 (defmethod reference-foreign ((class static-struct-class) location)
 570   (declare (ignore class))
 571   location)
 572
 573 (defmethod unreference-foreign ((class static-struct-class) location)
 574   (declare (ignore class location))
 575   nil)
 576
 577
 578 ;;; Pseudo type for structs which are inlined in other objects
 579
 580 (defmethod size-of ((type (eql 'inlined)) &rest args)
 581   (declare (ignore type))
 582   (foreign-size (first args)))
 583
 584 (defmethod reader-function ((type (eql 'inlined)) &rest args)
 585   (declare (ignore type))
 586   (destructuring-bind (class) args
 587     #'(lambda (location &optional (offset 0))
 588         (ensure-proxy-instance class
 589          (reference-foreign class (sap+ location offset))))))
 590
 591 (defmethod destroy-function ((type (eql 'inlined)) &rest args)
 592   (declare (ignore args))
 593   #'(lambda (location &optional (offset 0))
 594       (declare (ignore location offset))))
 595
 596 (export 'inlined)