From 1210ea93e088328d8f6cd8d91c57427c688f11c5 Mon Sep 17 00:00:00 2001 From: Dmitry Kalyanov Date: Sun, 2 Aug 2009 13:28:52 +0400 Subject: [PATCH] more improvements on gboxed --- glib/cl-gtk2-glib.asd | 1 - glib/gobject.boxed.lisp | 48 +++++++++++++++++++++++++++++++++++++-------- glib/gobject.package.lisp | 8 +++++++- 3 files changed, 47 insertions(+), 10 deletions(-) diff --git a/glib/cl-gtk2-glib.asd b/glib/cl-gtk2-glib.asd index 9a7e48d..1e38003 100644 --- a/glib/cl-gtk2-glib.asd +++ b/glib/cl-gtk2-glib.asd @@ -33,7 +33,6 @@ (:file "gobject.object-defs") (:file "gobject.foreign-gobject-subclassing") - (:file "gobject.foreign-gboxed") (:file "gobject.boxed") #+sbcl (:file "sbcl")) diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp index 78f9d72..d74f8fb 100644 --- a/glib/gobject.boxed.lisp +++ b/glib/gobject.boxed.lisp @@ -24,6 +24,12 @@ (defun get-g-boxed-foreign-info (name) (get name 'g-boxed-foreign-info))) +(defvar *g-type-name->g-boxed-foreign-info* (make-hash-table :test 'equal)) + +(defun get-g-boxed-foreign-info-for-gtype (g-type-designator) + (or (gethash (g-type-string g-type-designator) *g-type-name->g-boxed-foreign-info*) + (error "Unknown GBoxed type '~A'" (g-type-string g-type-designator)))) + (define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback) (let ((info (get-g-boxed-foreign-info name))) (assert info nil "Unknown foreign GBoxed type ~A" name) @@ -38,21 +44,23 @@ cstruct slots)) -(defmacro define-g-boxed-cstruct (name cstruct-name g-type-name &body slots) +(defmacro define-g-boxed-cstruct (name g-type-name &body slots) `(progn (defstruct ,name ,@(iter (for (name type &key initarg) in slots) (collect (list name initarg)))) - (defcstruct ,cstruct-name + (defcstruct ,(generated-cstruct-name name) ,@(iter (for (name type &key initarg) in slots) (collect `(,name ,type)))) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) (make-g-boxed-cstruct-wrapper-info :name ',name :g-type ,g-type-name - :cstruct ',cstruct-name + :cstruct ',(generated-cstruct-name name) :slots ',(iter (for (name type &key initarg) in slots) - (collect name))))))) + (collect name))) + (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*) + (get ',name 'g-boxed-foreign-info))))) (defgeneric create-temporary-native (type proxy) (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY) @@ -209,7 +217,9 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) (make-g-boxed-opaque-wrapper-info :name ',name - :g-type ,g-type-name)))))) + :g-type ,g-type-name) + (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*) + (get ',name 'g-boxed-foreign-info)))))) (defstruct var-structure name @@ -269,6 +279,11 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) (destructuring-bind (name type &key count initform) slot (make-var-structure-slot :name name :type type :count count :initform initform))) +(defun ensure-list (thing) + (if (listp thing) + thing + (list thing))) + (defun parse-variants (parent variants) (iter (for var-descr in variants) (for (options variant-name . slots) in variants) @@ -284,7 +299,7 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) (defun generated-cunion-name (symbol) (or (get symbol 'generated-cunion-name) - (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol)))))) + (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol)))))) (defun generate-cstruct-1 (struct) `(defcstruct ,(generated-cstruct-name (var-structure-name struct)) @@ -381,7 +396,7 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env) (make-load-form-saving-slots object :environment env)) -(defmacro define-boxed-variant-cstruct (name g-type-name &body slots) +(defmacro define-g-boxed-variant-cstruct (name g-type-name &body slots) (let* ((structure (parse-variant-structure-definition name slots))) `(progn ,@(generate-c-structures structure) ,@(generate-unions structure) @@ -394,7 +409,9 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) :native-type-decision-procedure ,(generate-native-type-decision-procedure structure) :proxy-type-decision-procedure - ,(generate-proxy-type-decision-procedure structure))))))) + ,(generate-proxy-type-decision-procedure structure)) + (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*) + (get ',name 'g-boxed-foreign-info)))))) (defun decide-native-type (info proxy) (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy)) @@ -440,3 +457,18 @@ This call is always paired by call to CREATE-REFERENCE-PROXY.")) (iter (for slot in slots) (setf (foreign-slot-value native-ptr actual-cstruct slot) (slot-value proxy slot))))) + +(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)) + (let ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric))) + (create-proxy-for-native boxed-type (g-value-get-boxed gvalue-ptr))))) + +(defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) value) + (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))) + (let* ((boxed-type (get-g-boxed-foreign-info-for-gtype type-numeric)) + (native (create-temporary-native boxed-type value))) + (g-value-take-boxed gvalue-ptr (g-boxed-copy type-numeric native)) + (free-temporary-native boxed-type value native)))) diff --git a/glib/gobject.package.lisp b/glib/gobject.package.lisp index f0131f3..5500600 100644 --- a/glib/gobject.package.lisp +++ b/glib/gobject.package.lisp @@ -179,7 +179,13 @@ #:*lisp-name-exceptions* #:*additional-properties* #:g-type= - #:g-type/=) + #:g-type/= + #:define-g-boxed-cstruct + #:define-g-boxed-opaque + #:g-boxed-opaque + #:g-boxed-opaque-pointer + #:define-g-boxed-variant-cstruct + #:g-boxed-foreign) (:documentation "CL-GTK2-GOBJECT is a binding to GObject type system. For information on GObject, see its @a[http://library.gnome.org/devel/gobject/stable/]{documentation}. -- 1.7.10.4