From: Dmitry Kalyanov Date: Wed, 5 Aug 2009 19:41:49 +0000 (+0400) Subject: glib: improve parsing and generation of cstructs X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=46b988933ec6aae9eb9ea60008f67b01138f1514;p=cl-gtk2.git glib: improve parsing and generation of cstructs --- diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp index 0c7f8be..688d82e 100644 --- a/glib/gobject.boxed.lisp +++ b/glib/gobject.boxed.lisp @@ -50,28 +50,55 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info)) - cstruct - slots)) + cstruct-description)) (defclass boxed-cstruct-foreign-type (g-boxed-foreign-type) ()) +(defstruct cstruct-slot-description + name + type + count + initform) + +(defmethod make-load-form ((object cstruct-slot-description) &optional environment) + (make-load-form-saving-slots object :environment environment)) + +(defstruct cstruct-description + name + slots) + +(defmethod make-load-form ((object cstruct-description) &optional environment) + (make-load-form-saving-slots object :environment environment)) + +(defun parse-cstruct-slot (slot) + (destructuring-bind (name type &key count initform) slot + (make-cstruct-slot-description :name name :type type :count count :initform initform))) + +(defun parse-cstruct-definition (name slots) + (make-cstruct-description :name name + :slots (mapcar #'parse-cstruct-slot slots))) + (defmacro define-g-boxed-cstruct (name g-type-name &body slots) - `(progn - (defstruct ,name - ,@(iter (for (name type &key count initarg) in slots) - (collect (list name initarg)))) - (defcstruct ,(generated-cstruct-name name) - ,@(iter (for (name type &key count initarg) in slots) - (collect `(,name ,type ,@(when count `(:count ,count)))))) - (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 ',(generated-cstruct-name name) - :slots ',(iter (for (name type &key initarg) in slots) - (collect name))) - (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*) - (get ',name 'g-boxed-foreign-info))))) + (let ((cstruct-description (parse-cstruct-definition name slots))) + `(progn + (defstruct ,name + ,@(iter (for slot in (cstruct-description-slots cstruct-description)) + (for name = (cstruct-slot-description-name slot)) + (for initform = (cstruct-slot-description-initform slot)) + (collect (list name initform)))) + (defcstruct ,(generated-cstruct-name name) + ,@(iter (for slot in (cstruct-description-slots cstruct-description)) + (for name = (cstruct-slot-description-name slot)) + (for type = (cstruct-slot-description-type slot)) + (for count = (cstruct-slot-description-count slot)) + (collect `(,name ,type ,@(when count `(:count ,count)))))) + (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-description ,cstruct-description) + (gethash ,g-type-name *g-type-name->g-boxed-foreign-info*) + (get ',name 'g-boxed-foreign-info)))))) (defmethod make-foreign-type ((info g-boxed-cstruct-wrapper-info) &key return-p) (make-instance 'boxed-cstruct-foreign-type :info info :return-p return-p)) @@ -84,8 +111,8 @@ (defmethod boxed-copy-fn ((info g-boxed-cstruct-wrapper-info) native) (if (g-boxed-info-g-type info) (g-boxed-copy (g-boxed-info-g-type info) native) - (let ((copy (foreign-alloc (g-boxed-cstruct-wrapper-info-cstruct info)))) - (memcpy copy native (foreign-type-size (g-boxed-cstruct-wrapper-info-cstruct info))) + (let ((copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name info))))) + (memcpy copy native (foreign-type-size (generated-cstruct-name (g-boxed-info-name info)))) copy))) (defmethod boxed-free-fn ((info g-boxed-cstruct-wrapper-info) native) @@ -93,46 +120,49 @@ (g-boxed-free (g-boxed-info-g-type info) native) (foreign-free native))) +(defun copy-slots-to-native (proxy native cstruct-description) + (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description))) + (for slot in (cstruct-description-slots cstruct-description)) + (for slot-name = (cstruct-slot-description-name slot)) + (setf (foreign-slot-value native cstruct-type slot-name) + (slot-value proxy slot-name)))) + +(defun copy-slots-to-proxy (proxy native cstruct-description) + (iter (with cstruct-type = (generated-cstruct-name (cstruct-description-name cstruct-description))) + (for slot in (cstruct-description-slots cstruct-description)) + (for slot-name = (cstruct-slot-description-name slot)) + (setf (slot-value proxy slot-name) + (foreign-slot-value native cstruct-type slot-name)))) + (defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type)) (if (null proxy) (null-pointer) (let* ((info (g-boxed-foreign-info type)) - (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info))) + (native-structure-type (generated-cstruct-name (g-boxed-info-name info)))) (with-foreign-object (native-structure native-structure-type) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info)) - (setf (foreign-slot-value native-structure native-structure-type slot) - (slot-value proxy slot))) + (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)) (values (boxed-copy-fn info native-structure) proxy))))) (defmethod free-translated-object (native-structure (type boxed-cstruct-foreign-type) proxy) (when proxy - (let* ((info (g-boxed-foreign-info type)) - (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info)) - (setf (slot-value proxy slot) - (foreign-slot-value native-structure native-structure-type slot))) + (let ((info (g-boxed-foreign-info type))) + (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)) (boxed-free-fn info native-structure)))) (defmethod translate-from-foreign (native-structure (type boxed-cstruct-foreign-type)) (unless (null-pointer-p native-structure) (let* ((info (g-boxed-foreign-info type)) - (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info)) (proxy-structure-type (g-boxed-info-name info)) (proxy (make-instance proxy-structure-type))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info)) - (setf (slot-value proxy slot) - (foreign-slot-value native-structure native-structure-type slot))) + (copy-slots-to-proxy proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info)) (when (g-boxed-foreign-return-p type) (boxed-free-fn info native-structure)) proxy))) (defmethod cleanup-translated-object-for-callback ((type boxed-cstruct-foreign-type) proxy native-structure) (when proxy - (let* ((info (g-boxed-foreign-info type)) - (native-structure-type (g-boxed-cstruct-wrapper-info-cstruct info))) - (iter (for slot in (g-boxed-cstruct-wrapper-info-slots info)) - (setf (foreign-slot-value native-structure native-structure-type slot) - (slot-value proxy slot)))))) + (let ((info (g-boxed-foreign-info type))) + (copy-slots-to-native proxy native-structure (g-boxed-cstruct-wrapper-info-cstruct-description info))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))