glib/gobject.foreign-gboxed.lisp

   1 (in-package :gobject)
   2
   3 (defun ensure-list (thing)
   4   (if (listp thing) thing (list thing)))
   5
   6 (defun slot->cstruct-slot (slot)
   7   (destructuring-bind (name type &key &allow-other-keys) slot
   8     `(,name ,type)))
   9
  10 (defun slot->slot-name (slot)
  11   (destructuring-bind (name type &key &allow-other-keys) slot
  12     (declare (ignore type))
  13     name))
  14
  15 (defun cstruct-definition (name slots)
  16   `(defcstruct ,name ,@(mapcar #'slot->cstruct-slot slots)))
  17
  18 (defun maybe-unlist (thing)
  19   (if (or (not (listp thing)) (cdr thing))
  20       thing
  21       (car thing)))
  22
  23 (defun slot->struct-slot (slot)
  24   (destructuring-bind (name type &key initform &allow-other-keys) slot
  25     (declare (ignore type))
  26     (maybe-unlist `(,name ,@(when initform (list initform))))))
  27
  28 (defun struct-definition (name superclass slots)
  29   `(defstruct ,@(if superclass
  30                     (list `(,name (:include ,superclass)))
  31                     (list name))
  32      ,@(mapcar #'slot->struct-slot slots)))
  33
  34 (define-foreign-type g-boxed-pointer-type ()
  35   ((name :accessor g-boxed-pointer-type-name :initarg :name)
  36    (outp :accessor g-boxed-pointer-type-outp :initarg :outp)))
  37
  38 (define-parse-method g-boxed-ptr (name &optional (type :in))
  39   (make-instance 'g-boxed-pointer-type :name name :actual-type :pointer :outp (ecase type
  40                                                                                 (:in nil)
  41                                                                                 (:in-out t))))
  42
  43 (defmethod translate-from-foreign (value (type g-boxed-pointer-type))
  44   (unless (null-pointer-p value)
  45     (parse-g-boxed value (g-boxed-pointer-type-name type))))
  46
  47 (defmethod translate-to-foreign (value (type g-boxed-pointer-type))
  48   (if value
  49       (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type)))))
  50         (real-unparse-g-boxed ptr value)
  51         (values ptr value))
  52       (null-pointer)))
  53
  54 (defmethod free-translated-object (ptr (type g-boxed-pointer-type) param)
  55   (unless (null-pointer-p ptr)
  56     (when (g-boxed-pointer-type-outp type)
  57       (let ((original-object param)
  58             (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type))))
  59         (if (eq new-real-name (type-of original-object))
  60             (real-parse-g-boxed ptr original-object)
  61             (error "Type has changed!")))))
  62   (foreign-free ptr))
  63
  64 (defmethod expand-to-foreign-dyn (value var body (type g-boxed-pointer-type))
  65   (let ((value-var (gensym)))
  66     `(with-foreign-object (,var ',(boxed-c-structure-name (g-boxed-pointer-type-name type)))
  67        (let ((,value-var ,value))
  68          (when ,value-var
  69            (real-unparse-g-boxed ,var ,value-var))
  70          (if (null ,value-var)
  71              (let ((,var (null-pointer)))
  72                ,@body)
  73              (progn ,@body
  74                     ,@(when (g-boxed-pointer-type-outp type)
  75                             (list `(when ,value-var
  76                                      (let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type))))
  77                                        (if (eq new-real-name (type-of ,value-var))
  78                                            (real-parse-g-boxed ,var ,value-var)
  79                                            (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name))))))))))))
  80
  81 (define-foreign-type g-boxed-inline-type ()
  82   ((name :accessor g-boxed-inline-type :initarg :name)))
  83
  84 (define-parse-method g-boxed-inline (name)
  85   (make-instance 'g-boxed-inline-type :name name :actual-type name))
  86
  87 (defgeneric real-parse-g-boxed (pointer object))
  88 (defgeneric real-unparse-g-boxed (pointer object))
  89
  90 (defun parse-g-boxed (pointer name)
  91   (unless (null-pointer-p pointer)
  92     (let* ((real-name (g-boxed-real-name pointer name))
  93            (object (make-instance real-name)))
  94       (real-parse-g-boxed pointer object)
  95       object)))
  96
  97 (defun boxed-alloc (type alloc-type)
  98   (ecase alloc-type
  99     (:cffi (foreign-alloc type))
 100     (:boxed (let ((pointer (foreign-alloc type)))
 101               (prog1 (g-boxed-copy (g-type-from-name (boxed-type-gname type)) pointer)
 102                 (foreign-free pointer))))))
 103
 104 (defun g-boxed->cstruct (object &key (alloc-type :cffi))
 105   (let ((pointer (boxed-alloc (type-of object) alloc-type)))
 106     (real-unparse-g-boxed pointer object)
 107     pointer))
 108
 109 (defun g-boxed-real-name (pointer name)
 110   (or (loop
 111          for (sub-name slot values) in (get name 'boxed-dispatch)
 112          do (debugf "Checking ~A ~A ~A against ~A.~A = ~A~%" sub-name slot values name slot (foreign-slot-value pointer name slot))
 113          when (member (foreign-slot-value pointer name slot) values :test 'equalp)
 114          return (g-boxed-real-name pointer sub-name))
 115       name))
 116
 117 (defun slot->slot-parser (class-name pointer-var slot)
 118   (destructuring-bind (slot-name slot-type &key parser &allow-other-keys) slot
 119     (cond
 120       (parser
 121        `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var)))
 122       ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
 123        `(setf ,slot-name (parse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ',(second slot-type))))
 124       (t
 125        `(setf ,slot-name (foreign-slot-value ,pointer-var ',class-name ',slot-name))))))
 126
 127 (defun parse-method-definition (name slots)
 128   (let ((slot-names (mapcar #'slot->slot-name slots)))
 129     `(defmethod real-parse-g-boxed (pointer (object ,name))
 130        (with-slots (,@slot-names) object
 131          ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots)))))
 132
 133 (defun slot->slot-unparser (class-name pointer-var slot object)
 134   (destructuring-bind (slot-name slot-type &key unparser &allow-other-keys) slot
 135     (cond
 136       (unparser
 137        `(funcall ,unparser ',class-name ,pointer-var ,object))
 138       ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
 139        `(real-unparse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ,slot-name))
 140       (t
 141        `(setf (foreign-slot-value ,pointer-var ',class-name ',slot-name) ,slot-name)))))
 142
 143 (defun unparse-method-definition (name slots)
 144   (let ((slot-names (mapcar #'slot->slot-name slots)))
 145     `(defmethod real-unparse-g-boxed (pointer (object ,name))
 146        (with-slots (,@slot-names) object
 147          ,@(mapcar (lambda (slot) (slot->slot-unparser name 'pointer slot 'object)) slots)))))
 148
 149 (defun slot->export-accessor (class-name slot)
 150   (destructuring-bind (slot-name slot-type &key &allow-other-keys) slot
 151     (declare (ignore slot-type))
 152     (let ((accessor-name (intern (format nil "~A-~A" (symbol-name class-name) (symbol-name slot-name))
 153                                  (symbol-package class-name))))
 154       `(export ',accessor-name (symbol-package ',accessor-name)))))
 155
 156 (defun struct-constructor-name (name)
 157   (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))
 158
 159 (defun get-g-boxed-direct-subclasses (name)
 160   (mapcar (lambda (spec) (destructuring-bind (name slot values) spec
 161                            (declare (ignore slot values))
 162                            name))
 163           (get name 'boxed-dispatch)))
 164
 165 (defun map-append (f &rest lists)
 166   (reduce #'append (apply #'mapcar f lists)))
 167
 168 (defun get-g-boxed-all-subclasses (name)
 169   (cons name
 170         (map-append #'get-g-boxed-all-subclasses (get-g-boxed-direct-subclasses name))))
 171
 172 (defun get-g-boxed-completed-c-definition (name union-name)
 173   `(defcunion ,union-name
 174      ,@(mapcar (lambda (sub-name)
 175                  `(,sub-name ,sub-name))
 176                (get-g-boxed-all-subclasses name))))
 177
 178 (defun g-boxed-root (name)
 179   (if (get name 'superclass)
 180       (g-boxed-root (get name 'superclass))
 181       name))
 182
 183 (defmacro update-g-boxed-root-c-class (name)
 184   (when (get name 'c-name)
 185     (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name))))
 186
 187 (defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots)
 188   "Defines the class corresponding to GBoxed type. Used only for structures that are passed (semantically) by value. E.g., GdkEvent.
 189 Single inheritance of classes is supported (and is used for definining different sub-types of GdkEvent). Decision of which class to use for a given C structure is made based on values of certain slots (see arguments @code{dispatch-slot} and @code{dispatch-values}).
 190
 191 Example:
 192
 193 @begin{pre}
 194 \(define-g-boxed-class (\"GdkEvent\" event-struct) event ()
 195   (type event-type)
 196   (window (g-object gdk-window))
 197   (send-event (:boolean :int8)))
 198
 199 \(define-g-boxed-class nil event-button ((event type (:button-press :2button-press :3button-press :button-release)))
 200   (time :uint32)
 201   (x :double)
 202   (y :double)
 203   (axes (fixed-array :double 2))
 204   (state :uint)
 205   (button :uint)
 206   (device (g-object device))
 207   (x-root :double)
 208   (y-root :double))
 209
 210 \(define-g-boxed-class \"GdkColor\" color ()
 211   (pixel :uint32 :initform 0)
 212   (red :uint16 :initform 0)
 213   (green :uint16 :initform 0)
 214   (blue :uint16 :initform 0))
 215 @end{pre}
 216 @arg[g-name-and-c-name]{@code{NIL} or list @code{(&optional g-name c-name)}; g-name is the GObject type name and c-name is the name of generated CFFI C structure.}
 217 @arg[name]{a symbol; name of the structure (defstruct) that is defined}
 218 @arg[superclass-and-dispatch]{@code{NIL} or list @code{(&optional superclass dispatch-slot dispatch-values)}}
 219 @arg[superclass]{a symbol denoting the superclass of the class being defined}
 220 @arg[dispatch-slot]{a symbol denoting the slot of the superclass that identifies the \"real\" class}
 221 @arg[dispatch-values]{a value or a list of values of @code{dispatch-slot} of @code{superclass} that correspond to the class being defined}
 222 @arg[export]{a boolean; defines whether all related symbols (@code{name} and generated slot accessors) should be exported from the current package}
 223 @arg[slots]{a list of slots; each slot is defined by list @code{(name type &key initform parser unparser)}.
 224 @begin{itemize}
 225 @item{@code{name} is the name of a slot}
 226 @item{@code{type} is a CFFI type of a slot}
 227 @item{@code{initform} is an expression that is the iniform of a slot in generated @code{defstruct}; used when the lisp code creates the object.}
 228 @item{@code{parser} is a function designator for a slot parser function (if a slot parsing depends on other slots of a structure; custom slot parsing is better implemented with CFFI foreign types). Slot parser function is a function that accepts two arguments: name of a slot and a pointer to C structure and returns the value of a slot}
 229 @item{@code{unparser} is a function designator for a slot unparser function. Slot unparsing function is a function that accepts three arguments: name of a slot, pointer to a C structure and a value of a slot. It should assign the slot value to a C structure.}
 230 @end{itemize}}"
 231   (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name)
 232     (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch
 233       (let* ((superclass-slots (get superclass 'boxed-combined-slots))
 234              (combined-slots (append superclass-slots slots)))
 235
 236         (setf c-name (or c-name (gensym "C-UNION-")))
 237         `(progn ,(cstruct-definition name combined-slots)
 238                 ,(struct-definition name superclass slots)
 239                 ,(parse-method-definition name combined-slots)
 240                 ,(unparse-method-definition name combined-slots)
 241                 (eval-when (:load-toplevel :compile-toplevel :execute)
 242                   (setf (get ',name 'boxed-slots) ',slots
 243                         (get ',name 'boxed-combined-slots) ',combined-slots
 244                         (get ',name 'superclass) ',superclass
 245                         (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
 246                   ,@(when superclass
 247                           (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
 248                 (update-g-boxed-root-c-class ,name)
 249                 ,@(when g-name
 250                         (list `(register-boxed-type ,g-name ',name)))
 251                 ,@(when export
 252                         (append (list `(export ',name (symbol-package ',name))
 253                                       `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
 254                                 (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))))
 255
 256 (defun boxed-c-structure-name (name)
 257   (get (g-boxed-root name) 'c-name))
 258
 259 (defclass g-boxed-ref ()
 260   ((pointer :accessor pointer :initarg :pointer))
 261   (:documentation "Class corresponding to GBoxed objects that are passed by reference to C structure rather than by value.
 262
 263 Instances of this class are collected by garbage collector. Each object has an owner: lisp code or C code. If owner is the lisp code then the corresponding C structure will be freed when the object is collected. Is the owner is the C code, the C structure lifetime is not connected with the lifetime of the object: it may be freed before or after the object becomes collected. If the owner if C code, lisp code must be careful not to access slots of the object after the C code frees the object (it cannot be tracked automatically).
 264
 265 When object is created by lisp code (using @fun{make-instance}), it is owned by lisp code unless explicitly disowned by @fun{disown-boxed-ref}. Disowning should be done when the object is passed to some function that becomes the owner of the reference.
 266
 267 When object is returned from a function, it depends on a function whether lisp code is the owner of GBoxed object. Return values and arguments of foreign functions are marked with CFFI foreign-type called @class{g-boxed-ref-type} that specifies (by the value of its @code{owner} slot) which code owns the reference."))
 268
 269 (defvar *g-boxed-gc-lock* (make-recursive-lock "g-boxed-gc-lock"))
 270 (defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value))
 271 (defvar *boxed-ref-count* (make-hash-table :test 'equal))
 272 (defvar *boxed-ref-owner* (make-hash-table :test 'equal))
 273
 274 (defun boxed-ref-free-function (name)
 275   (or (get name 'free-function)
 276       (error "g-boxed-ref class ~A has no free-function" name)))
 277
 278 (defun disown-boxed-ref (object)
 279   "Specify that the Lisp code no longer owns the reference to the @code{object}. Otherwise garbage collector would collect the @code{object} and corresponding C structure would be freed, causing dangling pointer (if C code does not free the structure) of double free (if C code frees the structure).
 280
 281 @arg[object]{an instance of @class{g-boxed-ref}}"
 282   (setf (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :foreign))
 283
 284 (defun dispose-boxed-ref (type pointer)
 285   (debugf "disposing g-boxed-ref ~A~%" pointer)
 286
 287   (unless (gethash (pointer-address pointer) *boxed-ref-count*)
 288     (error "g-boxed-ref ~A is already disposed from lisp-side" pointer))
 289   (with-recursive-lock-held (*g-boxed-gc-lock*)
 290     (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
 291       (when object
 292         (debugf "Removing finalization from ~A for pointer ~A~%" object pointer)
 293         (tg:cancel-finalization object)))
 294     (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*))
 295       (funcall (boxed-ref-free-function type) pointer))
 296     (remhash (pointer-address pointer) *known-boxed-refs*)
 297     (remhash (pointer-address pointer) *boxed-ref-count*)
 298     (remhash (pointer-address pointer) *boxed-ref-owner*)
 299     (debugf "Disposed of g-boxed-ref ~A (object ~A)~%"
 300             pointer
 301             (gethash (pointer-address pointer) *known-boxed-refs*))))
 302
 303 (defmethod initialize-instance :after ((object g-boxed-ref) &key)
 304   (with-recursive-lock-held (*g-boxed-gc-lock*)
 305     (let ((address (pointer-address (pointer object))))
 306       (let ((object (gethash address *known-boxed-refs*)))
 307         (when object
 308           (tg:cancel-finalization object)))
 309       (setf (gethash address *known-boxed-refs*) object)
 310       (setf (gethash address *boxed-ref-count*) 1)
 311       (setf (gethash address *boxed-ref-owner*)
 312             (gethash address *boxed-ref-owner* :foreign)))
 313     (debugf "setting g-boxed-ref-count of ~A (for ptr ~A) to 1~%" object (pointer object))
 314     (let ((p (pointer object))
 315           (type (type-of object))
 316           (s (format nil "~A" object)))
 317       (tg:finalize object (lambda ()
 318                             (handler-case
 319                                 (dispose-boxed-ref type p)
 320                               (error (e) (format t "Error ~A for ~A~%" e s))))))))
 321
 322 (defmethod release ((object g-boxed-ref))
 323   (debugf "releasing g-boxed-ref ~A~%" (pointer object))
 324   (unless (gethash (pointer-address (pointer object)) *boxed-ref-count*)
 325     (error "g-boxed-ref ~A is already disposed from lisp-side" (pointer object)))
 326   (decf (gethash (pointer-address (pointer object)) *boxed-ref-count*))
 327   (when (zerop (gethash (pointer-address (pointer object)) *boxed-ref-count*))
 328     (dispose-boxed-ref (type-of object) (pointer object))))
 329
 330 (define-foreign-type g-boxed-ref-type ()
 331   ((class-name :reader g-boxed-ref-class-name :initarg :class-name)
 332    (owner :reader g-boxed-ref-owner :initarg :owner :initform nil))
 333   (:actual-type :pointer))
 334
 335 (define-parse-method g-boxed-ref (class-name &key (owner :foreign))
 336   (unless (get class-name 'is-g-boxed-ref)
 337     (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name)))
 338   (make-instance 'g-boxed-ref-type :class-name class-name :owner owner))
 339
 340 (defmethod translate-to-foreign (value (type g-boxed-ref-type))
 341   (if value
 342       (pointer value)
 343       (null-pointer)))
 344
 345 (defun convert-g-boxed-ref-from-pointer (pointer name type)
 346   (unless (null-pointer-p pointer)
 347     (with-recursive-lock-held (*g-boxed-gc-lock*)
 348       (or (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
 349             (when object (debugf "Boxed-ref for ~A is found (~A)~%" pointer object))
 350             (when object (incf (gethash (pointer-address pointer) *boxed-ref-count*)))
 351             object)
 352           (let ((object (make-instance name :pointer pointer)))
 353             (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type))
 354             (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer object
 355                     (gethash (pointer-address pointer) *boxed-ref-owner*))
 356             object)))))
 357
 358 (defmethod translate-from-foreign (value (type g-boxed-ref-type))
 359   (let ((owner (or (gethash (pointer-address value) *boxed-ref-owner*) (g-boxed-ref-owner type)))) ;;This is needed to prevent changing ownership of already created
 360     (prog1
 361         (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type)
 362       (setf (gethash (pointer-address value) *boxed-ref-owner*) owner))))
 363
 364 (defun g-boxed-ref-slot->methods (class slot)
 365   (destructuring-bind (slot-name &key reader writer type (accessor slot-name)) slot
 366     `(progn ,@(when reader
 367                     (list `(defmethod ,accessor ((object ,class))
 368                              ,(if (stringp reader)
 369                                   `(foreign-funcall ,reader :pointer (pointer object) ,type)
 370                                   `(,reader object)))))
 371             ,@(when writer
 372                     (list `(defmethod (setf ,accessor) (new-value (object ,class))
 373                              ,(if (stringp writer)
 374                                   `(foreign-funcall ,writer :pointer (pointer object) ,type new-value)
 375                                   `(,writer new-value object))))))))
 376
 377 (defmacro define-g-boxed-ref (gobject-name name &rest properties)
 378   "Defines a class corresponding to GBoxed type that is passed by reference (e.g., GtkTextIter). Class is made a subclass of @code{g-boxed-ref}.
 379
 380 Example:
 381 @begin{pre}
 382 \(defun tree-iter-alloc () (glib:g-malloc (foreign-type-size 'tree-iter)))
 383 \(defun tree-iter-free (v) (glib:g-free v))
 384
 385 \(define-g-boxed-ref \"GtkTreeIter\" tree-iter
 386   (:slots (stamp :reader tree-iter-get-stamp :writer tree-iter-set-stamp :accessor tree-iter-stamp)
 387           (user-data :reader tree-iter-get-user-data :writer tree-iter-set-user-data :accessor tree-iter-user-data))
 388   (:alloc-function tree-iter-alloc)
 389   (:free-function tree-iter-free))
 390 @end{pre}
 391 @arg[gobject-name]{a string denoting the GObject type}
 392 @arg[name]{a symbol denoting the class name for generated class}
 393 @arg[properties]{p-list of options.
 394 Each option is a list @code{(name value)} where @code{name} is name of an option and @code{value} is its value.
 395 Following options are used:
 396 @begin{itemize}
 397 @item{@code{:free-function} (mandatory). Designator for a function that frees the allocated object. Accepts a single argument - pointer.}
 398 @item{@code{:alloc-function} (mandator). Designator for a function that accepts zero arguments and returns the C pointer to newly allocated object.}
 399 @item{@code{:slots} (optional). Slots specifications for GBoxed.
 400 Each slot is specified as a list @code{(slot-name &key reader writer type (accessor slot-name))}.
 401 @begin{itemize}
 402 @item{@code{slot-name} is a symbol - the name of a slot}
 403 @item{@code{type} is a CFFI type of a slot}
 404 @item{@code{reader} is a @code{NIL} or a string or a function designator.
 405
 406 If it is a @code{NIL} then the slot is not readable.
 407
 408 If it is a string then it names the C function that accepts the pointer to C structure and returns the value of a slot (of specified CFFI type).
 409
 410 If it is a function designator then it specifies a function that accepts the Lisp object and returns its slot value.}
 411 @item{@code{writer} is a @code{NIL} or string or a function designator.
 412
 413 If it is a @code{NIL} then the slot is not writable.
 414
 415 If it is a string then it names the C function that accepts the pointer to C structure and a value (of specified CFFI type) and assigns it to the slot of a structure. and returns the value of a slot (of specified CFFI type).
 416
 417 If it is a function designator then it specifies a function that accepts the new slot value and a Lisp object and assigns it to the slot.}
 418 @item{@code{accessor} is a symbol that names accessor function for this slot. By default it equals to @code{slot-name}.}
 419 @end{itemize}
 420 }
 421 @end{itemize}
 422 }"
 423   (let ((free-fn (second (find :free-function properties :key 'first)))
 424         (alloc-fn (second (find :alloc-function properties :key 'first)))
 425         (slots (rest (find :slots properties :key 'first))))
 426     (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified"))
 427     `(progn (defclass ,name (g-boxed-ref) ())
 428             (defmethod initialize-instance :before ((object ,name) &key pointer)
 429               (unless (or pointer (slot-boundp object 'pointer))
 430                 (setf (pointer object) (,alloc-fn)
 431                       (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :lisp)))
 432             (setf (get ',name 'free-function) ',free-fn)
 433             (eval-when (:compile-toplevel :load-toplevel :execute)
 434               (setf (get ',name 'is-g-boxed-ref) t))
 435             ,@(mapcar (lambda (slot)
 436                         (g-boxed-ref-slot->methods name slot))
 437                       slots)
 438             (register-boxed-type ,gobject-name ',name))))
 439
 440 (define-foreign-type fixed-array ()
 441   ((element-type :reader fixed-array-element-type :initarg :element-type :initform (error "Element type must be specified"))
 442    (array-size :reader fixed-array-array-size :initarg :array-size :initform (error "Array size must be specified")))
 443   (:actual-type :pointer)
 444   (:documentation
 445 "CFFI foreign type for an array of a fixed length. Slot @code{element-type}@see-slot{fixed-array-element-type} specifies the type of elements and slot @code{array-size}@see-slot{fixed-array-array-size} specifies the size of array (in elements)."))
 446
 447 (define-parse-method fixed-array (element-type array-size)
 448   (make-instance 'fixed-array :element-type element-type :array-size array-size))
 449
 450 (defmethod translate-from-foreign (ptr (type fixed-array))
 451   (when (not (null-pointer-p ptr))
 452     (let ((result (make-array (fixed-array-array-size type)))
 453           (el-type (fixed-array-element-type type)))
 454       (loop
 455          for i from 0 below (fixed-array-array-size type)
 456          do (setf (aref result i) (mem-aref ptr el-type i)))
 457       result)))
 458
 459 (defvar *registered-boxed-types* (make-hash-table :test 'equal))
 460 (defvar *registered-boxed-names* (make-hash-table))
 461 (defun register-boxed-type (name type)
 462   (setf (gethash name *registered-boxed-types*) type
 463         (gethash type *registered-boxed-names*) name))
 464 (defun get-registered-boxed-type (name)
 465   (gethash name *registered-boxed-types*))
 466
 467 (defun boxed-type-gname (type)
 468   (gethash type *registered-boxed-names*))
 469
 470 (defun set-gvalue-boxed (gvalue value)
 471   (if value
 472       (progn
 473         (cond
 474           ((typep value 'g-boxed-ref)
 475            (g-value-set-boxed gvalue (pointer value)))
 476           (t (g-value-take-boxed gvalue (g-boxed->cstruct value :alloc-type :boxed)))))
 477       (g-value-set-boxed gvalue (null-pointer))))
 478
 479 (defun parse-g-value-boxed (gvalue)
 480   (let* ((g-type (g-value-type gvalue))
 481          (type-name (g-type-name g-type))
 482          (boxed-type (get-registered-boxed-type type-name)))
 483     (unless boxed-type
 484       (warn "Type ~A is a not registered GBoxed~%" type-name)
 485       (return-from parse-g-value-boxed nil))
 486     (unless (null-pointer-p (g-value-get-boxed gvalue))
 487       (cond
 488         ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type (make-instance 'g-boxed-ref-type :class-name boxed-type :owner :foreign)))
 489         (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type))))))
 490
 491 (defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
 492   (declare (ignore parse-kind))
 493   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 494       (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
 495       (parse-g-value-boxed gvalue-ptr)))
 496
 497 (defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
 498   (format t "Converting ~A of GBoxed type ~A~%" value (g-type-string (g-value-type gvalue-ptr)))
 499   (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
 500       (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
 501       (set-gvalue-boxed gvalue-ptr value)))
 502