+++ /dev/null
-(in-package :gobject)
-
-(defun ensure-list (thing)
- (if (listp thing) thing (list thing)))
-
-(defun slot->cstruct-slot (slot)
- (destructuring-bind (name type &key &allow-other-keys) slot
- `(,name ,type)))
-
-(defun slot->slot-name (slot)
- (destructuring-bind (name type &key &allow-other-keys) slot
- (declare (ignore type))
- name))
-
-(defun cstruct-definition (name slots)
- `(defcstruct ,name ,@(mapcar #'slot->cstruct-slot slots)))
-
-(defun maybe-unlist (thing)
- (if (or (not (listp thing)) (cdr thing))
- thing
- (car thing)))
-
-(defun slot->struct-slot (slot)
- (destructuring-bind (name type &key initform &allow-other-keys) slot
- (declare (ignore type))
- (maybe-unlist `(,name ,@(when initform (list initform))))))
-
-(defun struct-definition (name superclass slots)
- `(defstruct ,@(if superclass
- (list `(,name (:include ,superclass)))
- (list name))
- ,@(mapcar #'slot->struct-slot slots)))
-
-(define-foreign-type g-boxed-pointer-type ()
- ((name :accessor g-boxed-pointer-type-name :initarg :name)
- (outp :accessor g-boxed-pointer-type-outp :initarg :outp)))
-
-(define-parse-method g-boxed-ptr (name &optional (type :in))
- (make-instance 'g-boxed-pointer-type :name name :actual-type :pointer :outp (ecase type
- (:in nil)
- (:in-out t))))
-
-(defmethod translate-from-foreign (value (type g-boxed-pointer-type))
- (unless (null-pointer-p value)
- (parse-g-boxed value (g-boxed-pointer-type-name type))))
-
-(defmethod translate-to-foreign (value (type g-boxed-pointer-type))
- (if value
- (let ((ptr (foreign-alloc (boxed-c-structure-name (g-boxed-pointer-type-name type)))))
- (real-unparse-g-boxed ptr value)
- (values ptr value))
- (null-pointer)))
-
-(defmethod free-translated-object (ptr (type g-boxed-pointer-type) param)
- (unless (null-pointer-p ptr)
- (when (g-boxed-pointer-type-outp type)
- (let ((original-object param)
- (new-real-name (g-boxed-real-name ptr (g-boxed-pointer-type-name type))))
- (if (eq new-real-name (type-of original-object))
- (real-parse-g-boxed ptr original-object)
- (error "Type has changed!")))))
- (foreign-free ptr))
-
-(defmethod expand-to-foreign-dyn (value var body (type g-boxed-pointer-type))
- (let ((value-var (gensym)))
- `(with-foreign-object (,var ',(boxed-c-structure-name (g-boxed-pointer-type-name type)))
- (let ((,value-var ,value))
- (when ,value-var
- (real-unparse-g-boxed ,var ,value-var))
- (if (null ,value-var)
- (let ((,var (null-pointer)))
- ,@body)
- (progn ,@body
- ,@(when (g-boxed-pointer-type-outp type)
- (list `(when ,value-var
- (let ((new-real-name (g-boxed-real-name ,var ',(g-boxed-pointer-type-name type))))
- (if (eq new-real-name (type-of ,value-var))
- (real-parse-g-boxed ,var ,value-var)
- (error "Type has changed from ~A to ~A" (type-of ,value-var) new-real-name))))))))))))
-
-(define-foreign-type g-boxed-inline-type ()
- ((name :accessor g-boxed-inline-type :initarg :name)))
-
-(define-parse-method g-boxed-inline (name)
- (make-instance 'g-boxed-inline-type :name name :actual-type name))
-
-(defgeneric real-parse-g-boxed (pointer object))
-(defgeneric real-unparse-g-boxed (pointer object))
-
-(defun parse-g-boxed (pointer name)
- (unless (null-pointer-p pointer)
- (let* ((real-name (g-boxed-real-name pointer name))
- (object (make-instance real-name)))
- (real-parse-g-boxed pointer object)
- object)))
-
-(defun boxed-alloc (type alloc-type)
- (ecase alloc-type
- (:cffi (foreign-alloc type))
- (:boxed (let ((pointer (foreign-alloc type)))
- (prog1 (g-boxed-copy (g-type-from-name (boxed-type-gname type)) pointer)
- (foreign-free pointer))))))
-
-(defun g-boxed->cstruct (object &key (alloc-type :cffi))
- (let ((pointer (boxed-alloc (type-of object) alloc-type)))
- (real-unparse-g-boxed pointer object)
- pointer))
-
-(defun g-boxed-real-name (pointer name)
- (or (loop
- for (sub-name slot values) in (get name 'boxed-dispatch)
- do (debugf "Checking ~A ~A ~A against ~A.~A = ~A~%" sub-name slot values name slot (foreign-slot-value pointer name slot))
- when (member (foreign-slot-value pointer name slot) values :test 'equalp)
- return (g-boxed-real-name pointer sub-name))
- name))
-
-(defun slot->slot-parser (class-name pointer-var slot)
- (destructuring-bind (slot-name slot-type &key parser &allow-other-keys) slot
- (cond
- (parser
- `(setf ,slot-name (funcall ,parser ',class-name ,pointer-var)))
- ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
- `(setf ,slot-name (parse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ',(second slot-type))))
- (t
- `(setf ,slot-name (foreign-slot-value ,pointer-var ',class-name ',slot-name))))))
-
-(defun parse-method-definition (name slots)
- (let ((slot-names (mapcar #'slot->slot-name slots)))
- `(defmethod real-parse-g-boxed (pointer (object ,name))
- (with-slots (,@slot-names) object
- ,@(mapcar (lambda (slot) (slot->slot-parser name 'pointer slot)) slots)))))
-
-(defun slot->slot-unparser (class-name pointer-var slot object)
- (destructuring-bind (slot-name slot-type &key unparser &allow-other-keys) slot
- (cond
- (unparser
- `(funcall ,unparser ',class-name ,pointer-var ,object))
- ((and (listp slot-type) (eq 'g-boxed-inline (first slot-type)))
- `(real-unparse-g-boxed (foreign-slot-pointer ,pointer-var ',class-name ',slot-name) ,slot-name))
- (t
- `(setf (foreign-slot-value ,pointer-var ',class-name ',slot-name) ,slot-name)))))
-
-(defun unparse-method-definition (name slots)
- (let ((slot-names (mapcar #'slot->slot-name slots)))
- `(defmethod real-unparse-g-boxed (pointer (object ,name))
- (with-slots (,@slot-names) object
- ,@(mapcar (lambda (slot) (slot->slot-unparser name 'pointer slot 'object)) slots)))))
-
-(defun slot->export-accessor (class-name slot)
- (destructuring-bind (slot-name slot-type &key &allow-other-keys) slot
- (declare (ignore slot-type))
- (let ((accessor-name (intern (format nil "~A-~A" (symbol-name class-name) (symbol-name slot-name))
- (symbol-package class-name))))
- `(export ',accessor-name (symbol-package ',accessor-name)))))
-
-(defun struct-constructor-name (name)
- (intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))
-
-(defun get-g-boxed-direct-subclasses (name)
- (mapcar (lambda (spec) (destructuring-bind (name slot values) spec
- (declare (ignore slot values))
- name))
- (get name 'boxed-dispatch)))
-
-(defun map-append (f &rest lists)
- (reduce #'append (apply #'mapcar f lists)))
-
-(defun get-g-boxed-all-subclasses (name)
- (cons name
- (map-append #'get-g-boxed-all-subclasses (get-g-boxed-direct-subclasses name))))
-
-(defun get-g-boxed-completed-c-definition (name union-name)
- `(defcunion ,union-name
- ,@(mapcar (lambda (sub-name)
- `(,sub-name ,sub-name))
- (get-g-boxed-all-subclasses name))))
-
-(defun g-boxed-root (name)
- (if (get name 'superclass)
- (g-boxed-root (get name 'superclass))
- name))
-
-(defmacro update-g-boxed-root-c-class (name)
- (when (get name 'c-name)
- (get-g-boxed-completed-c-definition (g-boxed-root name) (get name 'c-name))))
-
-(defmacro define-g-boxed-class (g-name-and-c-name name (&optional superclass-and-dispatch (export t)) &body slots)
- "Defines the class corresponding to GBoxed type. Used only for structures that are passed (semantically) by value. E.g., GdkEvent.
-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}).
-
-Example:
-
-@begin{pre}
-\(define-g-boxed-class (\"GdkEvent\" event-struct) event ()
- (type event-type)
- (window (g-object gdk-window))
- (send-event (:boolean :int8)))
-
-\(define-g-boxed-class nil event-button ((event type (:button-press :2button-press :3button-press :button-release)))
- (time :uint32)
- (x :double)
- (y :double)
- (axes (fixed-array :double 2))
- (state :uint)
- (button :uint)
- (device (g-object device))
- (x-root :double)
- (y-root :double))
-
-\(define-g-boxed-class \"GdkColor\" color ()
- (pixel :uint32 :initform 0)
- (red :uint16 :initform 0)
- (green :uint16 :initform 0)
- (blue :uint16 :initform 0))
-@end{pre}
-@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.}
-@arg[name]{a symbol; name of the structure (defstruct) that is defined}
-@arg[superclass-and-dispatch]{@code{NIL} or list @code{(&optional superclass dispatch-slot dispatch-values)}}
-@arg[superclass]{a symbol denoting the superclass of the class being defined}
-@arg[dispatch-slot]{a symbol denoting the slot of the superclass that identifies the \"real\" class}
-@arg[dispatch-values]{a value or a list of values of @code{dispatch-slot} of @code{superclass} that correspond to the class being defined}
-@arg[export]{a boolean; defines whether all related symbols (@code{name} and generated slot accessors) should be exported from the current package}
-@arg[slots]{a list of slots; each slot is defined by list @code{(name type &key initform parser unparser)}.
-@begin{itemize}
-@item{@code{name} is the name of a slot}
-@item{@code{type} is a CFFI type of a slot}
-@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.}
-@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}
-@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.}
-@end{itemize}}"
- (destructuring-bind (&optional g-name c-name) (ensure-list g-name-and-c-name)
- (destructuring-bind (&optional superclass dispatch-slot dispatch-values) superclass-and-dispatch
- (let* ((superclass-slots (get superclass 'boxed-combined-slots))
- (combined-slots (append superclass-slots slots)))
-
- (setf c-name (or c-name (gensym "C-UNION-")))
- `(progn ,(cstruct-definition name combined-slots)
- ,(struct-definition name superclass slots)
- ,(parse-method-definition name combined-slots)
- ,(unparse-method-definition name combined-slots)
- (eval-when (:load-toplevel :compile-toplevel :execute)
- (setf (get ',name 'boxed-slots) ',slots
- (get ',name 'boxed-combined-slots) ',combined-slots
- (get ',name 'superclass) ',superclass
- (get ',name 'c-name) (or (get ',name 'c-name) ',c-name))
- ,@(when superclass
- (list `(pushnew '(,name ,dispatch-slot ,(ensure-list dispatch-values)) (get ',superclass 'boxed-dispatch) :test 'equalp))))
- (update-g-boxed-root-c-class ,name)
- ,@(when g-name
- (list `(register-boxed-type ,g-name ',name)))
- ,@(when export
- (append (list `(export ',name (symbol-package ',name))
- `(export ',(struct-constructor-name name) (symbol-package ',(struct-constructor-name name))))
- (mapcar (lambda (slot) (slot->export-accessor name slot)) slots))))))))
-
-(defun boxed-c-structure-name (name)
- (get (g-boxed-root name) 'c-name))
-
-(defclass g-boxed-ref ()
- ((pointer :accessor pointer :initarg :pointer))
- (:documentation "Class corresponding to GBoxed objects that are passed by reference to C structure rather than by value.
-
-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).
-
-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.
-
-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."))
-
-(defvar *g-boxed-gc-lock* (make-recursive-lock "g-boxed-gc-lock"))
-(defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value))
-(defvar *boxed-ref-count* (make-hash-table :test 'equal))
-(defvar *boxed-ref-owner* (make-hash-table :test 'equal))
-
-(defun boxed-ref-free-function (name)
- (or (get name 'free-function)
- (error "g-boxed-ref class ~A has no free-function" name)))
-
-(defun disown-boxed-ref (object)
- "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).
-
-@arg[object]{an instance of @class{g-boxed-ref}}"
- (setf (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :foreign))
-
-(defun dispose-boxed-ref (type pointer)
- (debugf "disposing g-boxed-ref ~A~%" pointer)
-
- (unless (gethash (pointer-address pointer) *boxed-ref-count*)
- (error "g-boxed-ref ~A is already disposed from lisp-side" pointer))
- (with-recursive-lock-held (*g-boxed-gc-lock*)
- (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
- (when object
- (debugf "Removing finalization from ~A for pointer ~A~%" object pointer)
- (tg:cancel-finalization object)))
- (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*))
- (funcall (boxed-ref-free-function type) pointer))
- (remhash (pointer-address pointer) *known-boxed-refs*)
- (remhash (pointer-address pointer) *boxed-ref-count*)
- (remhash (pointer-address pointer) *boxed-ref-owner*)
- (debugf "Disposed of g-boxed-ref ~A (object ~A)~%"
- pointer
- (gethash (pointer-address pointer) *known-boxed-refs*))))
-
-(defmethod initialize-instance :after ((object g-boxed-ref) &key)
- (with-recursive-lock-held (*g-boxed-gc-lock*)
- (let ((address (pointer-address (pointer object))))
- (let ((object (gethash address *known-boxed-refs*)))
- (when object
- (tg:cancel-finalization object)))
- (setf (gethash address *known-boxed-refs*) object)
- (setf (gethash address *boxed-ref-count*) 1)
- (setf (gethash address *boxed-ref-owner*)
- (gethash address *boxed-ref-owner* :foreign)))
- (debugf "setting g-boxed-ref-count of ~A (for ptr ~A) to 1~%" object (pointer object))
- (let ((p (pointer object))
- (type (type-of object))
- (s (format nil "~A" object)))
- (tg:finalize object (lambda ()
- (handler-case
- (dispose-boxed-ref type p)
- (error (e) (format t "Error ~A for ~A~%" e s))))))))
-
-(defmethod release ((object g-boxed-ref))
- (debugf "releasing g-boxed-ref ~A~%" (pointer object))
- (unless (gethash (pointer-address (pointer object)) *boxed-ref-count*)
- (error "g-boxed-ref ~A is already disposed from lisp-side" (pointer object)))
- (decf (gethash (pointer-address (pointer object)) *boxed-ref-count*))
- (when (zerop (gethash (pointer-address (pointer object)) *boxed-ref-count*))
- (dispose-boxed-ref (type-of object) (pointer object))))
-
-(define-foreign-type g-boxed-ref-type ()
- ((class-name :reader g-boxed-ref-class-name :initarg :class-name)
- (owner :reader g-boxed-ref-owner :initarg :owner :initform nil))
- (:actual-type :pointer))
-
-(define-parse-method g-boxed-ref (class-name &key (owner :foreign))
- (unless (get class-name 'is-g-boxed-ref)
- (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name)))
- (make-instance 'g-boxed-ref-type :class-name class-name :owner owner))
-
-(defmethod translate-to-foreign (value (type g-boxed-ref-type))
- (if value
- (pointer value)
- (null-pointer)))
-
-(defun convert-g-boxed-ref-from-pointer (pointer name type)
- (unless (null-pointer-p pointer)
- (with-recursive-lock-held (*g-boxed-gc-lock*)
- (or (let ((object (gethash (pointer-address pointer) *known-boxed-refs*)))
- (when object (debugf "Boxed-ref for ~A is found (~A)~%" pointer object))
- (when object (incf (gethash (pointer-address pointer) *boxed-ref-count*)))
- object)
- (let ((object (make-instance name :pointer pointer)))
- (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type))
- (debugf "Boxed-ref for ~A is created (~A) with owner ~A~%" pointer object
- (gethash (pointer-address pointer) *boxed-ref-owner*))
- object)))))
-
-(defmethod translate-from-foreign (value (type g-boxed-ref-type))
- (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
- (prog1
- (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type)
- (setf (gethash (pointer-address value) *boxed-ref-owner*) owner))))
-
-(defun g-boxed-ref-slot->methods (class slot)
- (destructuring-bind (slot-name &key reader writer type (accessor slot-name)) slot
- `(progn ,@(when reader
- (list `(defmethod ,accessor ((object ,class))
- ,(if (stringp reader)
- `(foreign-funcall ,reader :pointer (pointer object) ,type)
- `(,reader object)))))
- ,@(when writer
- (list `(defmethod (setf ,accessor) (new-value (object ,class))
- ,(if (stringp writer)
- `(foreign-funcall ,writer :pointer (pointer object) ,type new-value)
- `(,writer new-value object))))))))
-
-(defmacro define-g-boxed-ref (gobject-name name &rest properties)
- "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}.
-
-Example:
-@begin{pre}
-\(defun tree-iter-alloc () (glib:g-malloc (foreign-type-size 'tree-iter)))
-\(defun tree-iter-free (v) (glib:g-free v))
-
-\(define-g-boxed-ref \"GtkTreeIter\" tree-iter
- (:slots (stamp :reader tree-iter-get-stamp :writer tree-iter-set-stamp :accessor tree-iter-stamp)
- (user-data :reader tree-iter-get-user-data :writer tree-iter-set-user-data :accessor tree-iter-user-data))
- (:alloc-function tree-iter-alloc)
- (:free-function tree-iter-free))
-@end{pre}
-@arg[gobject-name]{a string denoting the GObject type}
-@arg[name]{a symbol denoting the class name for generated class}
-@arg[properties]{p-list of options.
-Each option is a list @code{(name value)} where @code{name} is name of an option and @code{value} is its value.
-Following options are used:
-@begin{itemize}
-@item{@code{:free-function} (mandatory). Designator for a function that frees the allocated object. Accepts a single argument - pointer.}
-@item{@code{:alloc-function} (mandator). Designator for a function that accepts zero arguments and returns the C pointer to newly allocated object.}
-@item{@code{:slots} (optional). Slots specifications for GBoxed.
-Each slot is specified as a list @code{(slot-name &key reader writer type (accessor slot-name))}.
-@begin{itemize}
-@item{@code{slot-name} is a symbol - the name of a slot}
-@item{@code{type} is a CFFI type of a slot}
-@item{@code{reader} is a @code{NIL} or a string or a function designator.
-
-If it is a @code{NIL} then the slot is not readable.
-
-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).
-
-If it is a function designator then it specifies a function that accepts the Lisp object and returns its slot value.}
-@item{@code{writer} is a @code{NIL} or string or a function designator.
-
-If it is a @code{NIL} then the slot is not writable.
-
-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).
-
-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.}
-@item{@code{accessor} is a symbol that names accessor function for this slot. By default it equals to @code{slot-name}.}
-@end{itemize}
-}
-@end{itemize}
-}"
- (let ((free-fn (second (find :free-function properties :key 'first)))
- (alloc-fn (second (find :alloc-function properties :key 'first)))
- (slots (rest (find :slots properties :key 'first))))
- (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified"))
- `(progn (defclass ,name (g-boxed-ref) ())
- (defmethod initialize-instance :before ((object ,name) &key pointer)
- (unless (or pointer (slot-boundp object 'pointer))
- (setf (pointer object) (,alloc-fn)
- (gethash (pointer-address (pointer object)) *boxed-ref-owner*) :lisp)))
- (setf (get ',name 'free-function) ',free-fn)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'is-g-boxed-ref) t))
- ,@(mapcar (lambda (slot)
- (g-boxed-ref-slot->methods name slot))
- slots)
- (register-boxed-type ,gobject-name ',name))))
-
-(define-foreign-type fixed-array ()
- ((element-type :reader fixed-array-element-type :initarg :element-type :initform (error "Element type must be specified"))
- (array-size :reader fixed-array-array-size :initarg :array-size :initform (error "Array size must be specified")))
- (:actual-type :pointer)
- (:documentation
-"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)."))
-
-(define-parse-method fixed-array (element-type array-size)
- (make-instance 'fixed-array :element-type element-type :array-size array-size))
-
-(defmethod translate-from-foreign (ptr (type fixed-array))
- (when (not (null-pointer-p ptr))
- (let ((result (make-array (fixed-array-array-size type)))
- (el-type (fixed-array-element-type type)))
- (loop
- for i from 0 below (fixed-array-array-size type)
- do (setf (aref result i) (mem-aref ptr el-type i)))
- result)))
-
-(defvar *registered-boxed-types* (make-hash-table :test 'equal))
-(defvar *registered-boxed-names* (make-hash-table))
-(defun register-boxed-type (name type)
- (setf (gethash name *registered-boxed-types*) type
- (gethash type *registered-boxed-names*) name))
-(defun get-registered-boxed-type (name)
- (gethash name *registered-boxed-types*))
-
-(defun boxed-type-gname (type)
- (gethash type *registered-boxed-names*))
-
-(defun set-gvalue-boxed (gvalue value)
- (if value
- (progn
- (cond
- ((typep value 'g-boxed-ref)
- (g-value-set-boxed gvalue (pointer value)))
- (t (g-value-take-boxed gvalue (g-boxed->cstruct value :alloc-type :boxed)))))
- (g-value-set-boxed gvalue (null-pointer))))
-
-(defun parse-g-value-boxed (gvalue)
- (let* ((g-type (g-value-type gvalue))
- (type-name (g-type-name g-type))
- (boxed-type (get-registered-boxed-type type-name)))
- (unless boxed-type
- (warn "Type ~A is a not registered GBoxed~%" type-name)
- (return-from parse-g-value-boxed nil))
- (unless (null-pointer-p (g-value-get-boxed gvalue))
- (cond
- ((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)))
- (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type))))))
-
-(defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind)
- (declare (ignore parse-kind))
- (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
- (convert-from-foreign (g-value-get-boxed gvalue-ptr) '(glib:gstrv :free-from-foreign nil))
- (parse-g-value-boxed gvalue-ptr)))
-
-(defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value)
- (format t "Converting ~A of GBoxed type ~A~%" value (g-type-string (g-value-type gvalue-ptr)))
- (if (g-type= (g-value-type gvalue-ptr) (g-strv-get-type))
- (g-value-set-boxed gvalue-ptr (convert-to-foreign value '(glib:gstrv :free-from-foreign nil)))
- (set-gvalue-boxed gvalue-ptr value)))
-
projects / cl-gtk2.git / commitdiff