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.36 2006-02-26 15:30:01 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        ;; Need this to prevent type expansion in SBCL >= 0.9.8
 215        (let ((type (most-specific-slot-value direct-slotds 'type)))
 216          (unless (eq type *unbound-marker*)
 217            (setf (getf initargs :type) type)))
 218        (nconc initargs (call-next-method))))
 219     (direct-special-slot-definition
 220      (append '(:special t) (call-next-method)))
 221     (t (call-next-method))))
 222
 223
 224 (defmethod slot-value-using-class
 225     ((class virtual-slots-class) (object standard-object)
 226      (slotd effective-virtual-slot-definition))
 227   (if (funcall (slot-value slotd 'boundp-function) object)
 228       (funcall (slot-value slotd 'reader-function) object)
 229     (slot-unbound class object (slot-definition-name slotd))))
 230
 231 (defmethod slot-boundp-using-class
 232     ((class virtual-slots-class) (object standard-object)
 233      (slotd effective-virtual-slot-definition))
 234   (funcall (slot-value slotd 'boundp-function) object))
 235
 236 (defmethod (setf slot-value-using-class)
 237     (value (class virtual-slots-class) (object standard-object)
 238      (slotd effective-virtual-slot-definition))
 239   (funcall (slot-value slotd 'writer-function) value object))
 240
 241
 242 (defmethod validate-superclass
 243     ((class virtual-slots-class) (super standard-class))
 244   t)
 245
 246
 247 (defmethod slot-definition-special ((slotd standard-direct-slot-definition))
 248   (declare (ignore slotd))
 249   nil)
 250
 251 (defmethod slot-definition-special ((slotd standard-effective-slot-definition))
 252   (declare (ignore slotd))
 253   nil)
 254
 255
 256 ;;;; Proxy cache
 257
 258 (defvar *instance-cache* (make-hash-table :test #'eql))
 259
 260 (defun cache-instance (instance &optional (weak-ref t))
 261   (setf
 262    (gethash (sap-int (foreign-location instance)) *instance-cache*)
 263    (if weak-ref
 264        (make-weak-pointer instance)
 265      instance)))
 266
 267 (defun find-cached-instance (location)
 268   (let ((ref (gethash (sap-int location) *instance-cache*)))
 269     (when ref
 270       (if (weak-pointer-p ref)
 271           (weak-pointer-value ref)
 272         ref))))
 273
 274 (defun instance-cached-p (location)
 275   (gethash (sap-int location) *instance-cache*))
 276
 277 (defun remove-cached-instance (location)
 278   (remhash (sap-int location) *instance-cache*))
 279
 280 ;; For debuging
 281 (defun list-cached-instances ()
 282   (let ((instances ()))
 283     (maphash #'(lambda (location ref)
 284                  (declare (ignore location))
 285                  (push ref instances))
 286              *instance-cache*)
 287     instances))
 288
 289 ;; Instances that gets invalidated tend to be short lived, but created
 290 ;; in large numbers. So we're keeping them in a hash table to be able
 291 ;; to reuse them (and thus reduce consing)
 292 (defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
 293
 294 (defun cache-invalidated-instance (instance)
 295   (push instance
 296    (gethash (class-of instance) *invalidated-instance-cache*)))
 297
 298 (defun find-invalidated-instance (class)
 299   (when (gethash class *invalidated-instance-cache*)
 300     (pop (gethash class *invalidated-instance-cache*))))
 301
 302 (defun list-invalidated-instances ()
 303   (let ((instances ()))
 304     (maphash #'(lambda (location ref)
 305                  (declare (ignore location))
 306                  (push ref instances))
 307              *invalidated-instance-cache*)
 308     instances))
 309
 310
 311
 312 ;;;; Proxy for alien instances
 313
 314 ;; TODO: add a ref-counted-proxy subclass
 315 (defclass proxy ()
 316   ((location :special t :type pointer))
 317   (:metaclass virtual-slots-class))
 318
 319 (defgeneric instance-finalizer (object))
 320 (defgeneric reference-foreign (class location))
 321 (defgeneric unreference-foreign (class location))
 322 (defgeneric invalidate-instance (object))
 323 (defgeneric allocate-foreign (object &key &allow-other-keys))
 324
 325 (defun foreign-location (instance)
 326   (slot-value instance 'location))
 327
 328 (defun (setf foreign-location) (location instance)
 329   (setf (slot-value instance 'location) location))
 330
 331 (defun proxy-valid-p (instance)
 332   (slot-boundp instance 'location))
 333
 334 (defmethod reference-foreign ((name symbol) location)
 335   (reference-foreign (find-class name) location))
 336
 337 (defmethod unreference-foreign ((name symbol) location)
 338   (unreference-foreign (find-class name) location))
 339
 340 (defmethod unreference-foreign :around ((class class) location)
 341   (unless (null-pointer-p location)
 342     (call-next-method)))
 343
 344 (defmethod print-object ((instance proxy) stream)
 345   (print-unreadable-object (instance stream :type t :identity nil)
 346     (if (slot-boundp instance 'location)
 347         (format stream "at 0x~X" (sap-int (foreign-location instance)))
 348       (write-string "at <unbound>" stream))))
 349
 350 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
 351   (setf
 352    (foreign-location instance)
 353    (apply #'allocate-foreign instance initargs))
 354   (prog1
 355       (call-next-method)
 356     (cache-instance instance)
 357     (finalize instance (instance-finalizer instance))))
 358
 359 (defmethod instance-finalizer ((instance proxy))
 360   (let ((location (foreign-location instance))
 361         (class (class-of instance)))
 362 ;;     (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
 363 ;;       (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
 364     #'(lambda ()
 365         (remove-cached-instance location)
 366         (unreference-foreign class location))))
 367
 368 ;; Any reference to the foreign object the instance may have held
 369 ;; should be released before this method is invoked
 370 (defmethod invalidate-instance ((instance proxy))
 371   (remove-cached-instance (foreign-location instance))
 372   (slot-makunbound instance 'location)
 373   (cancel-finalization instance)
 374   (cache-invalidated-instance instance))
 375
 376
 377 ;;;; Metaclass used for subclasses of proxy
 378
 379 (defgeneric most-specific-proxy-superclass (class))
 380 (defgeneric direct-proxy-superclass (class))
 381
 382
 383 (eval-when (:compile-toplevel :load-toplevel :execute)
 384   (defclass proxy-class (virtual-slots-class)
 385     ((size :reader foreign-size)))
 386
 387   (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
 388     ((offset :reader slot-definition-offset :initarg :offset))
 389     (:default-initargs :allocation :alien))
 390
 391   (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
 392     ((offset :reader slot-definition-offset :initarg :offset)))
 393
 394   (defmethod most-specific-proxy-superclass ((class proxy-class))
 395     (find-if
 396      #'(lambda (class)
 397          (subtypep (class-name class) 'proxy))
 398      (cdr (compute-class-precedence-list class))))
 399
 400   (defmethod direct-proxy-superclass ((class proxy-class))
 401     (find-if
 402      #'(lambda (class)
 403          (subtypep (class-name class) 'proxy))
 404      (class-direct-superclasses class)))
 405
 406   (defmethod shared-initialize ((class proxy-class) names &key size)
 407     (call-next-method)
 408     (cond
 409       (size (setf (slot-value class 'size) (first size)))
 410       ((slot-boundp class 'size) (slot-makunbound class 'size))))
 411
 412   (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
 413     (case (getf initargs :allocation)
 414       (:alien (find-class 'direct-alien-slot-definition))
 415       (t (call-next-method))))
 416
 417   (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 418     (case (getf initargs :allocation)
 419       (:alien (find-class 'effective-alien-slot-definition))
 420       (t (call-next-method))))
 421
 422
 423   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
 424     (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
 425         (nconc
 426          (list :offset (most-specific-slot-value direct-slotds 'offset))
 427          (call-next-method))
 428       (call-next-method)))
 429
 430
 431   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
 432     (with-slots (offset) slotd
 433       (let ((type (slot-definition-type slotd)))
 434         (unless (slot-boundp slotd 'getter)
 435           (let ((reader (reader-function type)))
 436             (setf
 437              (slot-value slotd 'getter)
 438              #'(lambda (object)
 439                  (funcall reader (foreign-location object) offset)))))
 440
 441         (unless (slot-boundp slotd 'setter)
 442           (let ((writer (writer-function type))
 443                 (destroy (destroy-function type)))
 444             (setf
 445              (slot-value slotd 'setter)
 446              #'(lambda (value object)
 447                  (let ((location (foreign-location object)))
 448                    (funcall destroy location offset) ; destroy old value
 449                    (funcall writer value location offset))))))))
 450
 451     (call-next-method))
 452
 453   ;; TODO: call some C code to detect this a compile time
 454   (defconstant +struct-alignmen+ 4)
 455
 456   (defun align-offset (size)
 457     (if (zerop (mod size +struct-alignmen+))
 458         size
 459       (+ size (- +struct-alignmen+ (mod size +struct-alignmen+)))))
 460
 461   (defmethod compute-slots ((class proxy-class))
 462     (let ((alien-slots
 463            (remove-if-not
 464             #'(lambda (slotd)
 465                 (eq (slot-definition-allocation slotd) :alien))
 466             (class-direct-slots class))))
 467       (when alien-slots
 468         (loop
 469          as offset = (align-offset (foreign-size
 470                                     (most-specific-proxy-superclass class)))
 471                      then (align-offset
 472                            (+
 473                             (slot-definition-offset slotd)
 474                             (size-of (slot-definition-type slotd))))
 475        for slotd in alien-slots
 476        unless (slot-boundp slotd 'offset)
 477        do (setf (slot-value slotd 'offset) offset))))
 478     (call-next-method))
 479
 480   (defmethod validate-superclass ((class proxy-class) (super standard-class))
 481     (subtypep (class-name super) 'proxy))
 482
 483   (defmethod foreign-size ((class-name symbol))
 484     (foreign-size (find-class class-name))))
 485
 486 (defmethod foreign-size ((object proxy))
 487   (foreign-size (class-of object)))
 488
 489
 490 (define-type-method alien-type ((class proxy))
 491   (declare (ignore class))
 492   (alien-type 'pointer))
 493
 494 (define-type-method size-of ((class proxy))
 495   (declare (ignore class))
 496   (size-of 'pointer))
 497
 498 (define-type-method from-alien-form ((type proxy) location)
 499   (let ((class (type-expand type)))
 500     `(ensure-proxy-instance ',class ,location)))
 501
 502 (define-type-method from-alien-function ((type proxy))
 503   (let ((class (type-expand type)))
 504     #'(lambda (location)
 505         (ensure-proxy-instance class location))))
 506
 507 (define-type-method to-alien-form ((type proxy) instance)
 508   (declare (ignore type))
 509   `(foreign-location ,instance))
 510
 511 (define-type-method to-alien-function ((type proxy))
 512   (declare (ignore type))
 513   #'foreign-location)
 514
 515 (define-type-method copy-from-alien-form ((type proxy) location)
 516   (let ((class (type-expand type)))
 517     `(ensure-proxy-instance ',class (reference-foreign ',class ,location))))
 518
 519 (define-type-method copy-from-alien-function ((type proxy))
 520   (let ((class (type-expand type)))
 521     #'(lambda (location)
 522         (ensure-proxy-instance class (reference-foreign class location)))))
 523
 524 (define-type-method copy-to-alien-form ((type proxy) instance)
 525   (let ((class (type-expand type)))
 526     `(reference-foreign ',class (foreign-location ,instance))))
 527
 528 (define-type-method copy-to-alien-function ((type proxy))
 529   (let ((class (type-expand type)))
 530     #'(lambda (instance)
 531         (reference-foreign class (foreign-location instance)))))
 532
 533 (define-type-method writer-function ((type proxy))
 534   (let ((class (type-expand type)))
 535     #'(lambda (instance location &optional (offset 0))
 536         (assert (null-pointer-p (sap-ref-sap location offset)))
 537         (setf
 538          (sap-ref-sap location offset)
 539          (reference-foreign class (foreign-location instance))))))
 540
 541 (define-type-method reader-function ((type proxy))
 542   (let ((class (type-expand type)))
 543     #'(lambda (location &optional (offset 0) weak-p)
 544         (declare (ignore weak-p))
 545         (let ((instance (sap-ref-sap location offset)))
 546           (unless (null-pointer-p instance)
 547             (ensure-proxy-instance class (reference-foreign class instance)))))))
 548
 549 (define-type-method destroy-function ((type proxy))
 550   (let ((class (type-expand type)))
 551     #'(lambda (location &optional (offset 0))
 552         (unreference-foreign class (sap-ref-sap location offset)))))
 553
 554 (define-type-method unbound-value ((type proxy))
 555   (declare (ignore type))
 556   nil)
 557
 558 (defun ensure-proxy-instance (class location &rest initargs)
 559   "Returns a proxy object representing the foreign object at the give
 560 location. If an existing object is not found in the cache
 561 MAKE-PROXY-INSTANCE is called to create one."
 562   (unless (null-pointer-p location)
 563     (or
 564      #-debug-ref-counting(find-cached-instance location)
 565      #+debug-ref-counting
 566      (let ((instance (find-cached-instance location)))
 567        (when instance
 568          (format t "Object found in cache: ~A~%" instance)
 569          instance))
 570      (let ((instance (apply #'make-proxy-instance class location initargs)))
 571        (cache-instance instance)
 572        instance))))
 573
 574 (defgeneric make-proxy-instance (class location &key weak)
 575   (:documentation "Creates a new proxy object representing the foreign
 576 object at the give location. If WEAK is non NIL the foreign memory
 577 will not be released when the proxy is garbage collected."))
 578
 579 (defmethod make-proxy-instance ((class symbol) location &rest initargs)
 580   (apply #'make-proxy-instance (find-class class) location initargs))
 581
 582 (defmethod make-proxy-instance ((class proxy-class) location &key weak)
 583   (let ((instance
 584          (or
 585           (find-invalidated-instance class)
 586           (allocate-instance class))))
 587     (setf (foreign-location instance) location)
 588     (unless weak
 589       (finalize instance (instance-finalizer instance)))
 590     instance))
 591
 592
 593 ;;;; Superclasses for wrapping of C structures
 594
 595 (defclass struct (proxy)
 596   ()
 597   (:metaclass proxy-class)
 598   (:size 0))
 599
 600 (defmethod allocate-foreign ((struct struct) &rest initargs)
 601   (declare (ignore initargs))
 602   (let ((size (foreign-size (class-of struct))))
 603     (if (zerop size)
 604         (error "~A has zero size" (class-of struct))
 605       (allocate-memory size))))
 606
 607
 608 ;;;; Metaclasses used for subclasses of struct
 609
 610 (eval-when (:compile-toplevel :load-toplevel :execute)
 611   (defclass struct-class (proxy-class)
 612     ()))
 613
 614 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
 615   (if (not (getf initargs :allocation))
 616       (find-class 'direct-alien-slot-definition)
 617     (call-next-method)))
 618
 619 (defmethod reference-foreign ((class struct-class) location)
 620   (copy-memory location (foreign-size class)))
 621
 622 (defmethod unreference-foreign ((class struct-class) location)
 623   (deallocate-memory location))
 624
 625 (defmethod compute-slots :around ((class struct-class))
 626     (let ((slots (call-next-method)))
 627       (when (and
 628              #-sbcl>=0.9.8(class-finalized-p class)
 629              (not (slot-boundp class 'size)))
 630         (let ((size (loop
 631                      for slotd in slots
 632                      when (eq (slot-definition-allocation slotd) :alien)
 633                      maximize (+
 634                                (slot-definition-offset slotd)
 635                                (size-of (slot-definition-type slotd))))))
 636           (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+)))))
 637       slots))
 638
 639 (define-type-method callback-from-alien-form ((type struct) form)
 640   (let ((class (type-expand type)))
 641     `(ensure-proxy-instance ',class ,form :weak t)))
 642
 643 (define-type-method callback-cleanup-form ((type struct) form)
 644   (declare (ignore type))
 645   `(invalidate-instance ,form))
 646
 647 (define-type-method reader-function ((type struct))
 648   (let ((class (type-expand type)))
 649     #'(lambda (location &optional (offset 0) weak-p)
 650         (let ((instance (sap-ref-sap location offset)))
 651           (unless (null-pointer-p instance)
 652             (if weak-p
 653                 (ensure-proxy-instance class instance :weak t)
 654               (ensure-proxy-instance class (reference-foreign class instance))))))))
 655
 656
 657 (defclass static-struct-class (struct-class)
 658   ())
 659
 660 (defmethod reference-foreign ((class static-struct-class) location)
 661   (declare (ignore class))
 662   location)
 663
 664 (defmethod unreference-foreign ((class static-struct-class) location)
 665   (declare (ignore class location))
 666   nil)
 667
 668 ;;; Pseudo type for structs which are inlined in other objects
 669
 670 (deftype inlined (type) type)
 671
 672 (define-type-method size-of ((type inlined))
 673   (let ((class (type-expand (second type))))
 674     (foreign-size class)))
 675
 676 (define-type-method reader-function ((type inlined))
 677   (let ((class (type-expand (second type))))
 678     #'(lambda (location &optional (offset 0) weak-p)
 679         (declare (ignore weak-p))
 680         (ensure-proxy-instance class
 681          (reference-foreign class (sap+ location offset))))))
 682
 683 (define-type-method writer-function ((type inlined))
 684   (let ((class (type-expand (second type))))
 685     #'(lambda (instance location &optional (offset 0))
 686         (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset)))))
 687
 688 (export 'inlined)