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.39 2006/03/06 14:28:03 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     ((special :initarg :special :accessor slot-definition-special)))
  47
  48   (defclass effective-special-slot-definition (standard-effective-slot-definition)
  49     ((special :initarg :special :accessor slot-definition-special))))
  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
  63 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
  64   (cond
  65    ((eq (getf initargs :allocation) :virtual)
  66     (find-class 'direct-virtual-slot-definition))
  67    ((getf initargs :special)
  68     (find-class 'direct-special-slot-definition))
  69    (t (call-next-method))))
  70
  71 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
  72   (cond
  73    ((eq (getf initargs :allocation) :virtual)
  74     (find-class 'effective-virtual-slot-definition))
  75    ((getf initargs :special)
  76     (find-class 'effective-special-slot-definition))
  77    (t (call-next-method))))
  78
  79
  80 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
  81   (if (not (slot-boundp slotd 'getter))
  82       (setf
  83        (slot-value slotd 'reader-function)
  84        #'(lambda (object)
  85            (declare (ignore object))
  86            (error "Slot is not readable: ~A" (slot-definition-name slotd)))
  87        (slot-value slotd 'boundp-function)
  88        #'(lambda (object) (declare (ignore object)) nil))
  89
  90     (let ((getter-function
  91            (let ((getter (slot-value slotd 'getter)))
  92              (etypecase getter
  93                (function getter)
  94                (symbol
  95                 #'(lambda (object)
  96                     (funcall getter object)))
  97                (string
  98                 (let ((reader nil))
  99                   (setf (slot-value slotd 'reader-function)
 100                         #'(lambda (object)
 101                             (unless reader
 102                               (setq reader
 103                                (mkbinding getter
 104                                 (slot-definition-type slotd) 'pointer)))
 105                             (funcall reader (foreign-location object))))))))))
 106
 107       (setf
 108        (slot-value slotd 'boundp-function)
 109        (cond
 110         ((slot-boundp slotd 'unbound)
 111          (let ((unbound-value (slot-value slotd 'unbound)))
 112            #'(lambda (object)
 113                (not (eq (funcall getter-function object) unbound-value)))))
 114         ((slot-boundp slotd 'boundp)
 115          (let ((boundp (slot-value slotd 'boundp)))
 116            (etypecase boundp
 117              (function boundp)
 118              (symbol #'(lambda (object)
 119                          (funcall boundp object)))
 120              (string (let ((reader ()))
 121                        #'(lambda (object)
 122                            (unless reader
 123                              (setq reader
 124                               (mkbinding boundp
 125                                (slot-definition-type slotd) 'pointer)))
 126                            (funcall reader (foreign-location object))))))))
 127         ((let ((unbound-value-method
 128                 (find-applicable-type-method 'unbound-value
 129                  (slot-definition-type slotd) nil)))
 130            (when unbound-value-method
 131              (let ((unbound-value
 132                     (funcall unbound-value-method (slot-definition-type slotd))))
 133                #'(lambda (object)
 134                    (not (eq (funcall getter-function object) unbound-value)))))))
 135         (#'(lambda (object) (declare (ignore object)) t))))
 136
 137       (setf
 138        (slot-value slotd 'reader-function)
 139        (cond
 140         ((slot-boundp slotd 'unbound)
 141          (let ((unbound (slot-value slotd 'unbound))
 142                (slot-name (slot-definition-name slotd)))
 143            #'(lambda (object)
 144                (let ((value (funcall getter-function object)))
 145                  (if (eq value unbound)
 146                      (slot-unbound (class-of object) object slot-name)
 147                    value)))))
 148         ((slot-boundp slotd 'boundp)
 149          (let ((boundp-function (slot-value slotd 'boundp-function)))
 150            #'(lambda (object)
 151                (and
 152                 (funcall boundp-function object)
 153                 (funcall getter-function object)))))
 154         ((let ((unbound-value-method
 155                 (find-applicable-type-method 'unbound-value
 156                  (slot-definition-type slotd) nil)))
 157            (when unbound-value-method
 158              (let ((unbound-value
 159                     (funcall unbound-value-method (slot-definition-type slotd)))
 160                    (slot-name (slot-definition-name slotd)))
 161                #'(lambda (object)
 162                    (let ((value (funcall getter-function object)))
 163                      (if (eq value unbound-value)
 164                          (slot-unbound (class-of object) object slot-name)
 165                          value)))))))
 166         (getter-function)))))
 167
 168   (setf
 169    (slot-value slotd 'writer-function)
 170    (if (not (slot-boundp slotd 'setter))
 171        #'(lambda (value object)
 172            (declare (ignore value object))
 173            (error "Slot is not writable: ~A" (slot-definition-name slotd)))
 174      (with-slots (setter) slotd
 175        (etypecase setter
 176          (function setter)
 177          ((or symbol cons)
 178           #'(lambda (value object)
 179               (funcall (fdefinition setter) value object)))
 180          (string
 181           (let ((writer ()))
 182             (setf
 183              (slot-value slotd 'writer-function)
 184              #'(lambda (value object)
 185                  (unless writer
 186                    (setq writer
 187                     (mkbinding setter 'nil 'pointer
 188                      (slot-definition-type slotd))))
 189                  (funcall writer (foreign-location object) value)))))))))
 190
 191   #-sbcl>=0.9.8(initialize-internal-slot-gfs (slot-definition-name slotd)))
 192
 193
 194
 195 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
 196   nil)
 197
 198 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
 199   (typecase (first direct-slotds)
 200     (direct-virtual-slot-definition
 201      (let ((initargs ()))
 202        (let ((getter (most-specific-slot-value direct-slotds 'getter)))
 203          (unless (eq getter *unbound-marker*)
 204            (setf (getf initargs :getter) getter)))
 205        (let ((setter (most-specific-slot-value direct-slotds 'setter)))
 206          (unless (eq setter *unbound-marker*)
 207            (setf (getf initargs :setter) setter)))
 208        (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
 209          (unless (eq unbound *unbound-marker*)
 210            (setf (getf initargs :unbound) unbound)))
 211        (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
 212          (unless (eq boundp *unbound-marker*)
 213            (setf (getf initargs :boundp) boundp)))
 214        ;; This is needed to avoid type expansion in SBCL version >= 0.9.8
 215        #+sbcl>=0.9.8
 216        (let ((type (most-specific-slot-value direct-slotds #-sbcl>=0.9.10'type #+sbcl>=0.9.10'sb-pcl::%type)))
 217          (unless (eq type *unbound-marker*)
 218            (setf (getf initargs :type) type)))
 219        (nconc initargs (call-next-method))))
 220     (direct-special-slot-definition
 221      (append '(:special t) (call-next-method)))
 222     (t (call-next-method))))
 223
 224
 225 (defmethod slot-value-using-class
 226     ((class virtual-slots-class) (object standard-object)
 227      (slotd effective-virtual-slot-definition))
 228   (if (funcall (slot-value slotd 'boundp-function) object)
 229       (funcall (slot-value slotd 'reader-function) object)
 230     (slot-unbound class object (slot-definition-name slotd))))
 231
 232 (defmethod slot-boundp-using-class
 233     ((class virtual-slots-class) (object standard-object)
 234      (slotd effective-virtual-slot-definition))
 235   (funcall (slot-value slotd 'boundp-function) object))
 236
 237 (defmethod (setf slot-value-using-class)
 238     (value (class virtual-slots-class) (object standard-object)
 239      (slotd effective-virtual-slot-definition))
 240   (funcall (slot-value slotd 'writer-function) value object))
 241
 242
 243 (defmethod validate-superclass
 244     ((class virtual-slots-class) (super standard-class))
 245   t)
 246
 247
 248 (defmethod slot-definition-special ((slotd standard-direct-slot-definition))
 249   (declare (ignore slotd))
 250   nil)
 251
 252 (defmethod slot-definition-special ((slotd standard-effective-slot-definition))
 253   (declare (ignore slotd))
 254   nil)
 255
 256
 257 ;;;; Proxy cache
 258
 259 (defvar *instance-cache* (make-hash-table :test #'eql))
 260
 261 (defun cache-instance (instance &optional (weak-ref t))
 262   (setf
 263    (gethash (sap-int (foreign-location instance)) *instance-cache*)
 264    (if weak-ref
 265        (make-weak-pointer instance)
 266      instance)))
 267
 268 (defun find-cached-instance (location)
 269   (let ((ref (gethash (sap-int location) *instance-cache*)))
 270     (when ref
 271       (if (weak-pointer-p ref)
 272           (weak-pointer-value ref)
 273         ref))))
 274
 275 (defun instance-cached-p (location)
 276   (gethash (sap-int location) *instance-cache*))
 277
 278 (defun remove-cached-instance (location)
 279   (remhash (sap-int location) *instance-cache*))
 280
 281 ;; For debuging
 282 (defun list-cached-instances ()
 283   (let ((instances ()))
 284     (maphash #'(lambda (location ref)
 285                  (declare (ignore location))
 286                  (push ref instances))
 287              *instance-cache*)
 288     instances))
 289
 290 ;; Instances that gets invalidated tend to be short lived, but created
 291 ;; in large numbers. So we're keeping them in a hash table to be able
 292 ;; to reuse them (and thus reduce consing)
 293 (defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
 294
 295 (defun cache-invalidated-instance (instance)
 296   (push instance
 297    (gethash (class-of instance) *invalidated-instance-cache*)))
 298
 299 (defun find-invalidated-instance (class)
 300   (when (gethash class *invalidated-instance-cache*)
 301     (pop (gethash class *invalidated-instance-cache*))))
 302
 303 (defun list-invalidated-instances ()
 304   (let ((instances ()))
 305     (maphash #'(lambda (location ref)
 306                  (declare (ignore location))
 307                  (push ref instances))
 308              *invalidated-instance-cache*)
 309     instances))
 310
 311
 312
 313 ;;;; Proxy for alien instances
 314
 315 ;; TODO: add a ref-counted-proxy subclass
 316 (defclass proxy ()
 317   ((location :special t :type pointer))
 318   (:metaclass virtual-slots-class))
 319
 320 (defgeneric instance-finalizer (object))
 321 (defgeneric reference-foreign (class location))
 322 (defgeneric unreference-foreign (class location))
 323 (defgeneric invalidate-instance (object))
 324 (defgeneric allocate-foreign (object &key &allow-other-keys))
 325
 326 (defun foreign-location (instance)
 327   (slot-value instance 'location))
 328
 329 (defun (setf foreign-location) (location instance)
 330   (setf (slot-value instance 'location) location))
 331
 332 (defun proxy-valid-p (instance)
 333   (slot-boundp instance 'location))
 334
 335 (defmethod reference-foreign ((name symbol) location)
 336   (reference-foreign (find-class name) location))
 337
 338 (defmethod unreference-foreign ((name symbol) location)
 339   (unreference-foreign (find-class name) location))
 340
 341 (defmethod unreference-foreign :around ((class class) location)
 342   (unless (null-pointer-p location)
 343     (call-next-method)))
 344
 345 (defmethod print-object ((instance proxy) stream)
 346   (print-unreadable-object (instance stream :type t :identity nil)
 347     (if (slot-boundp instance 'location)
 348         (format stream "at 0x~X" (sap-int (foreign-location instance)))
 349       (write-string "at <unbound>" stream))))
 350
 351 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
 352   (setf
 353    (foreign-location instance)
 354    (apply #'allocate-foreign instance initargs))
 355   (prog1
 356       (call-next-method)
 357     (cache-instance instance)
 358     (finalize instance (instance-finalizer instance))))
 359
 360 (defmethod instance-finalizer ((instance proxy))
 361   (let ((location (foreign-location instance))
 362         (class (class-of instance)))
 363 ;;     (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
 364 ;;       (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
 365     #'(lambda ()
 366         (remove-cached-instance location)
 367         (unreference-foreign class location))))
 368
 369 ;; Any reference to the foreign object the instance may have held
 370 ;; should be released before this method is invoked
 371 (defmethod invalidate-instance ((instance proxy))
 372   (remove-cached-instance (foreign-location instance))
 373   (slot-makunbound instance 'location)
 374   (cancel-finalization instance)
 375   (cache-invalidated-instance instance))
 376
 377
 378 ;;;; Metaclass used for subclasses of proxy
 379
 380 (defgeneric most-specific-proxy-superclass (class))
 381 (defgeneric direct-proxy-superclass (class))
 382
 383
 384 (eval-when (:compile-toplevel :load-toplevel :execute)
 385   (defclass proxy-class (virtual-slots-class)
 386     ((size :reader foreign-size)))
 387
 388   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 389     ((offset :reader slot-definition-offset :initarg :offset))
 390     (:default-initargs :allocation :alien))
 391
 392   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 393     ((offset :reader slot-definition-offset :initarg :offset)))
 394
 395   (defmethod most-specific-proxy-superclass ((class proxy-class))
 396     (find-if
 397      #'(lambda (class)
 398          (subtypep (class-name class) 'proxy))
 399      (cdr (compute-class-precedence-list class))))
 400
 401   (defmethod direct-proxy-superclass ((class proxy-class))
 402     (find-if
 403      #'(lambda (class)
 404          (subtypep (class-name class) 'proxy))
 405      (class-direct-superclasses class)))
 406
 407   (defmethod shared-initialize ((class proxy-class) names &key size)
 408     (call-next-method)
 409     (cond
 410       (size (setf (slot-value class 'size) (first size)))
 411       ((slot-boundp class 'size) (slot-makunbound class 'size))))
 412
 413   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
 414     (case (getf initargs :allocation)
 415       (:alien (find-class 'direct-alien-slot-definition))
 416       (t (call-next-method))))
 417
 418   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 419     (case (getf initargs :allocation)
 420       (:alien (find-class 'effective-alien-slot-definition))
 421       (t (call-next-method))))
 422
 423
 424   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
 425     (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
 426         (nconc
 427          (list :offset (most-specific-slot-value direct-slotds 'offset))
 428          (call-next-method))
 429       (call-next-method)))
 430
 431
 432   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
 433     (with-slots (offset) slotd
 434       (let ((type (slot-definition-type slotd)))
 435         (unless (slot-boundp slotd 'getter)
 436           (let ((reader (reader-function type)))
 437             (setf
 438              (slot-value slotd 'getter)
 439              #'(lambda (object)
 440                  (funcall reader (foreign-location object) offset)))))
 441
 442         (unless (slot-boundp slotd 'setter)
 443           (let ((writer (writer-function type))
 444                 (destroy (destroy-function type)))
 445             (setf
 446              (slot-value slotd 'setter)
 447              #'(lambda (value object)
 448                  (let ((location (foreign-location object)))
 449                    (funcall destroy location offset) ; destroy old value
 450                    (funcall writer value location offset))))))))
 451
 452     (call-next-method))
 453
 454   (defconstant +struct-alignmen+
 455     #+sbcl (/ (sb-alien-internals:alien-type-alignment
 456                (sb-alien-internals:parse-alien-type
 457                 'system-area-pointer nil))
 458               8)
 459     #-sbcl 4)
 460
 461   (defun align-offset (size)
 462     (if (zerop (mod size +struct-alignmen+))
 463         size
 464       (+ size (- +struct-alignmen+ (mod size +struct-alignmen+)))))
 465
 466   (defmethod compute-slots ((class proxy-class))
 467     (let ((alien-slots
 468            (remove-if-not
 469             #'(lambda (slotd)
 470                 (eq (slot-definition-allocation slotd) :alien))
 471             (class-direct-slots class))))
 472       (when alien-slots
 473         (loop
 474          as offset = (align-offset (foreign-size
 475                                     (most-specific-proxy-superclass class)))
 476                      then (align-offset
 477                            (+
 478                             (slot-definition-offset slotd)
 479                             (size-of (slot-definition-type slotd))))
 480        for slotd in alien-slots
 481        unless (slot-boundp slotd 'offset)
 482        do (setf (slot-value slotd 'offset) offset))))
 483     (call-next-method))
 484
 485   (defmethod validate-superclass ((class proxy-class) (super standard-class))
 486     (subtypep (class-name super) 'proxy))
 487
 488   (defmethod foreign-size ((class-name symbol))
 489     (foreign-size (find-class class-name))))
 490
 491 (defmethod foreign-size ((object proxy))
 492   (foreign-size (class-of object)))
 493
 494
 495 (define-type-method alien-type ((class proxy))
 496   (declare (ignore class))
 497   (alien-type 'pointer))
 498
 499 (define-type-method size-of ((class proxy))
 500   (declare (ignore class))
 501   (size-of 'pointer))
 502
 503 (define-type-method from-alien-form ((type proxy) location)
 504   (let ((class (type-expand type)))
 505     `(ensure-proxy-instance ',class ,location)))
 506
 507 (define-type-method from-alien-function ((type proxy))
 508   (let ((class (type-expand type)))
 509     #'(lambda (location)
 510         (ensure-proxy-instance class location))))
 511
 512 (define-type-method to-alien-form ((type proxy) instance)
 513   (declare (ignore type))
 514   `(foreign-location ,instance))
 515
 516 (define-type-method to-alien-function ((type proxy))
 517   (declare (ignore type))
 518   #'foreign-location)
 519
 520 (define-type-method copy-from-alien-form ((type proxy) location)
 521   (let ((class (type-expand type)))
 522     `(ensure-proxy-instance ',class (reference-foreign ',class ,location))))
 523
 524 (define-type-method copy-from-alien-function ((type proxy))
 525   (let ((class (type-expand type)))
 526     #'(lambda (location)
 527         (ensure-proxy-instance class (reference-foreign class location)))))
 528
 529 (define-type-method copy-to-alien-form ((type proxy) instance)
 530   (let ((class (type-expand type)))
 531     `(reference-foreign ',class (foreign-location ,instance))))
 532
 533 (define-type-method copy-to-alien-function ((type proxy))
 534   (let ((class (type-expand type)))
 535     #'(lambda (instance)
 536         (reference-foreign class (foreign-location instance)))))
 537
 538 (define-type-method writer-function ((type proxy))
 539   (let ((class (type-expand type)))
 540     #'(lambda (instance location &optional (offset 0))
 541         (assert (null-pointer-p (sap-ref-sap location offset)))
 542         (setf
 543          (sap-ref-sap location offset)
 544          (reference-foreign class (foreign-location instance))))))
 545
 546 (define-type-method reader-function ((type proxy))
 547   (let ((class (type-expand type)))
 548     #'(lambda (location &optional (offset 0) weak-p)
 549         (declare (ignore weak-p))
 550         (let ((instance (sap-ref-sap location offset)))
 551           (unless (null-pointer-p instance)
 552             (ensure-proxy-instance class (reference-foreign class instance)))))))
 553
 554 (define-type-method destroy-function ((type proxy))
 555   (let ((class (type-expand type)))
 556     #'(lambda (location &optional (offset 0))
 557         (unreference-foreign class (sap-ref-sap location offset)))))
 558
 559 (define-type-method unbound-value ((type proxy))
 560   (declare (ignore type))
 561   nil)
 562
 563 (defun ensure-proxy-instance (class location &rest initargs)
 564   "Returns a proxy object representing the foreign object at the give
 565 location. If an existing object is not found in the cache
 566 MAKE-PROXY-INSTANCE is called to create one."
 567   (unless (null-pointer-p location)
 568     (or
 569      #-debug-ref-counting(find-cached-instance location)
 570      #+debug-ref-counting
 571      (let ((instance (find-cached-instance location)))
 572        (when instance
 573          (format t "Object found in cache: ~A~%" instance)
 574          instance))
 575      (let ((instance (apply #'make-proxy-instance class location initargs)))
 576        (cache-instance instance)
 577        instance))))
 578
 579 (defgeneric make-proxy-instance (class location &key weak)
 580   (:documentation "Creates a new proxy object representing the foreign
 581 object at the give location. If WEAK is non NIL the foreign memory
 582 will not be released when the proxy is garbage collected."))
 583
 584 (defmethod make-proxy-instance ((class symbol) location &rest initargs)
 585   (apply #'make-proxy-instance (find-class class) location initargs))
 586
 587 (defmethod make-proxy-instance ((class proxy-class) location &key weak)
 588   (let ((instance
 589          (or
 590           (find-invalidated-instance class)
 591           (allocate-instance class))))
 592     (setf (foreign-location instance) location)
 593     (unless weak
 594       (finalize instance (instance-finalizer instance)))
 595     instance))
 596
 597
 598 ;;;; Superclasses for wrapping of C structures
 599
 600 (defclass struct (proxy)
 601   ()
 602   (:metaclass proxy-class)
 603   (:size 0))
 604
 605 (defmethod allocate-foreign ((struct struct) &rest initargs)
 606   (declare (ignore initargs))
 607   (let ((size (foreign-size (class-of struct))))
 608     (if (zerop size)
 609         (error "~A has zero size" (class-of struct))
 610       (allocate-memory size))))
 611
 612
 613 ;;;; Metaclasses used for subclasses of struct
 614
 615 (eval-when (:compile-toplevel :load-toplevel :execute)
 616   (defclass struct-class (proxy-class)
 617     ()))
 618
 619 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
 620   (if (not (getf initargs :allocation))
 621       (find-class 'direct-alien-slot-definition)
 622     (call-next-method)))
 623
 624 (defmethod reference-foreign ((class struct-class) location)
 625   (copy-memory location (foreign-size class)))
 626
 627 (defmethod unreference-foreign ((class struct-class) location)
 628   (deallocate-memory location))
 629
 630 (defmethod compute-slots :around ((class struct-class))
 631     (let ((slots (call-next-method)))
 632       (when (and
 633              #-sbcl>=0.9.8(class-finalized-p class)
 634              (not (slot-boundp class 'size)))
 635         (let ((size (loop
 636                      for slotd in slots
 637                      when (eq (slot-definition-allocation slotd) :alien)
 638                      maximize (+
 639                                (slot-definition-offset slotd)
 640                                (size-of (slot-definition-type slotd))))))
 641           (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+)))))
 642       slots))
 643
 644 (define-type-method callback-from-alien-form ((type struct) form)
 645   (let ((class (type-expand type)))
 646     `(ensure-proxy-instance ',class ,form :weak t)))
 647
 648 (define-type-method callback-cleanup-form ((type struct) form)
 649   (declare (ignore type))
 650   `(invalidate-instance ,form))
 651
 652 (define-type-method reader-function ((type struct))
 653   (let ((class (type-expand type)))
 654     #'(lambda (location &optional (offset 0) weak-p)
 655         (let ((instance (sap-ref-sap location offset)))
 656           (unless (null-pointer-p instance)
 657             (if weak-p
 658                 (ensure-proxy-instance class instance :weak t)
 659               (ensure-proxy-instance class (reference-foreign class instance))))))))
 660
 661
 662 (defclass static-struct-class (struct-class)
 663   ())
 664
 665 (defmethod reference-foreign ((class static-struct-class) location)
 666   (declare (ignore class))
 667   location)
 668
 669 (defmethod unreference-foreign ((class static-struct-class) location)
 670   (declare (ignore class location))
 671   nil)
 672
 673 ;;; Pseudo type for structs which are inlined in other objects
 674
 675 (deftype inlined (type) type)
 676
 677 (define-type-method size-of ((type inlined))
 678   (let ((class (second (type-expand-to 'inlined type))))
 679     (foreign-size class)))
 680
 681 (define-type-method reader-function ((type inlined))
 682   (let ((class (second (type-expand-to 'inlined type))))
 683     #'(lambda (location &optional (offset 0) weak-p)
 684         (declare (ignore weak-p))
 685         (ensure-proxy-instance class
 686          (reference-foreign class (sap+ location offset))))))
 687
 688 (define-type-method writer-function ((type inlined))
 689   (let ((class (second (type-expand-to 'inlined type))))
 690     #'(lambda (instance location &optional (offset 0))
 691         (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset)))))
 692
 693 (define-type-method destroy-function ((type inlined))
 694   (declare (ignore type))
 695   #'(lambda (location &optional offset)
 696       (declare (ignore location offset))))
 697
 698
 699 (export 'inlined)