X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.boxed.lisp;h=6ab321c4c34140b8bfe9c894c80218c6feee4732;hb=873f2b61eea29d7d2f9083cd32d08adabb1fc80b;hp=688d82e128d57d06c2c336d89cbb37966c5872cd;hpb=46b988933ec6aae9eb9ea60008f67b01138f1514;p=cl-gtk2.git diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp index 688d82e..6ab321c 100644 --- a/glib/gobject.boxed.lisp +++ b/glib/gobject.boxed.lisp @@ -58,11 +58,18 @@ name type count - initform) + initform + inline-p) + +(defstruct (cstruct-inline-slot-description (:include cstruct-slot-description)) + boxed-type-name) (defmethod make-load-form ((object cstruct-slot-description) &optional environment) (make-load-form-saving-slots object :environment environment)) +(defmethod make-load-form ((object cstruct-inline-slot-description) &optional environment) + (make-load-form-saving-slots object :environment environment)) + (defstruct cstruct-description name slots) @@ -71,8 +78,13 @@ (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))) + (destructuring-bind (name type &key count initform inline) slot + (if inline + (make-cstruct-inline-slot-description :name name :type (generated-cunion-name type) + :count count :initform initform :inline-p inline + :boxed-type-name type) + (make-cstruct-inline-slot-description :name name :type type + :count count :initform initform :inline-p inline)))) (defun parse-cstruct-definition (name slots) (make-cstruct-description :name name @@ -92,6 +104,8 @@ (for type = (cstruct-slot-description-type slot)) (for count = (cstruct-slot-description-count slot)) (collect `(,name ,type ,@(when count `(:count ,count)))))) + (defcunion ,(generated-cunion-name name) + (,name ,(generated-cstruct-name name))) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) (make-g-boxed-cstruct-wrapper-info :name ',name @@ -124,15 +138,42 @@ (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)))) + (cond + ((cstruct-slot-description-count slot) + (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name)) + (with array = (slot-value proxy slot-name)) + (for i from 0 below (cstruct-slot-description-count slot)) + (setf (mem-aref ptr (cstruct-slot-description-type slot) i) + (aref array i)))) + ((cstruct-slot-description-inline-p slot) + (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot)))) + (copy-slots-to-native (slot-value proxy slot-name) + (foreign-slot-pointer native cstruct-type slot-name) + (g-boxed-cstruct-wrapper-info-cstruct-description info)))) + (t + (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)))) + (cond + ((cstruct-slot-description-count slot) + (setf (slot-value proxy slot-name) (make-array (list (cstruct-slot-description-count slot)))) + (iter (with ptr = (foreign-slot-pointer native cstruct-type slot-name)) + (with array = (slot-value proxy slot-name)) + (for i from 0 below (cstruct-slot-description-count slot)) + (setf (aref array i) + (mem-aref ptr (cstruct-slot-description-type slot) i)))) + ((cstruct-slot-description-inline-p slot) + (let ((info (get-g-boxed-foreign-info (cstruct-inline-slot-description-boxed-type-name slot)))) + (setf (slot-value proxy slot-name) (make-instance (cstruct-inline-slot-description-boxed-type-name slot))) + (copy-slots-to-proxy (slot-value proxy slot-name) + (foreign-slot-pointer native cstruct-type slot-name) + (g-boxed-cstruct-wrapper-info-cstruct-description info)))) + (t (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) @@ -175,6 +216,9 @@ :initform nil :accessor g-boxed-opaque-pointer))) +(defmethod pointer ((object g-boxed-opaque)) + (g-boxed-opaque-pointer object)) + (defmethod make-foreign-type ((info g-boxed-opaque-wrapper-info) &key return-p) (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p)) @@ -202,15 +246,13 @@ (defmacro define-g-boxed-opaque (name g-type-name &key (alloc (error "Alloc must be specified"))) (let ((native-copy (gensym "NATIVE-COPY-")) - (instance (gensym "INSTANCE-")) - (finalizer (gensym "FINALIZER-"))) + (instance (gensym "INSTANCE-"))) `(progn (defclass ,name (g-boxed-opaque) ()) (defmethod initialize-instance :after ((,instance ,name) &key &allow-other-keys) (unless (g-boxed-opaque-pointer ,instance) (let ((,native-copy ,alloc)) - (flet ((,finalizer () (boxed-free-fn ,g-type-name ,native-copy))) - (setf (g-boxed-opaque-pointer ,instance) ,native-copy) - (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy)))))) + (setf (g-boxed-opaque-pointer ,instance) ,native-copy) + (finalize ,instance (make-boxed-free-finalizer (get ',name 'g-boxed-foreign-info) ,native-copy))))) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) (make-g-boxed-opaque-wrapper-info :name ',name @@ -223,24 +265,16 @@ parent slots discriminator-slot - variants) + variants + resulting-cstruct-description) (defstruct var-structure-variant discriminating-values structure) -(defstruct var-structure-slot - name - type - initform - count) - (defmethod make-load-form ((object var-structure) &optional env) (make-load-form-saving-slots object :environment env)) -(defmethod make-load-form ((object var-structure-slot) &optional env) - (make-load-form-saving-slots object :environment env)) - (defmethod make-load-form ((object var-structure-variant) &optional env) (make-load-form-saving-slots object :environment env)) @@ -267,14 +301,26 @@ (error "Structure has more than one discriminator slot")) (setf (var-structure-discriminator-slot result) (second slot) (var-structure-variants result) (parse-variants result (nthcdr 2 slot)))) - (push (parse-slot slot) (var-structure-slots result))) + (push (parse-cstruct-slot slot) (var-structure-slots result))) (finally (setf (var-structure-slots result) (reverse (var-structure-slots result))) + (unless parent + (set-variant-result-structure result)) (return result)))) -(defun parse-slot (slot) - (destructuring-bind (name type &key count initform) slot - (make-var-structure-slot :name name :type type :count count :initform initform))) +(defun set-variant-result-structure (var-structure) + (setf (var-structure-resulting-cstruct-description var-structure) + (make-cstruct-description + :name + (var-structure-name var-structure) + :slots + (append + (when (var-structure-parent var-structure) + (cstruct-description-slots (var-structure-resulting-cstruct-description (var-structure-parent var-structure)))) + (var-structure-slots var-structure)))) + (iter (for variant in (var-structure-variants var-structure)) + (for child-var-structure = (var-structure-variant-structure variant)) + (set-variant-result-structure child-var-structure))) (defun ensure-list (thing) (if (listp thing) @@ -291,34 +337,28 @@ (collect variant))) (defun generated-cstruct-name (symbol) - (or (get symbol 'generated-cstruct-name) - (setf (get symbol 'generated-cstruct-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol)))))) + (intern (format nil "~A-CSTRUCT-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol))) (defun generated-cunion-name (symbol) - (or (get symbol 'generated-cunion-name) - (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CUNION-" (symbol-name symbol)))))) + (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol))) (defun generate-cstruct-1 (struct) - `(defcstruct ,(generated-cstruct-name (var-structure-name struct)) - ,@(iter (for slot in (var-struct-all-slots struct)) - (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot) - ,@(when (var-structure-slot-count slot) - `(:count ,(var-structure-slot-count slot)))))))) + `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct)) + ,@(iter (for slot in (cstruct-description-slots struct)) + (collect `(,(cstruct-slot-description-name slot) ,(cstruct-slot-description-type slot) + ,@(when (cstruct-slot-description-count slot) + `(:count ,(cstruct-slot-description-count slot)))))))) (defun generate-c-structures (structure) (iter (for str in (all-structures structure)) - (collect (generate-cstruct-1 str)))) + (for cstruct = (var-structure-resulting-cstruct-description str)) + (collect (generate-cstruct-1 cstruct)))) -(defun generate-union-1 (struct) +(defun generate-variant-union (struct) `(defcunion ,(generated-cunion-name (var-structure-name struct)) - ,@(iter (for variant in (all-structures struct)) - (unless (eq struct variant) - (collect `(,(var-structure-name variant) - ,(generated-cunion-name (var-structure-name variant)))))))) - -(defun generate-unions (struct) - (iter (for str in (all-structures struct)) - (collect (generate-union-1 str)))) + ,@(iter (for str in (all-structures struct)) + (collect `(,(var-structure-name str) + ,(generated-cstruct-name (var-structure-name str))))))) (defun generate-structure-1 (str) `(defstruct ,(if (var-structure-parent str) @@ -331,8 +371,8 @@ :key #'var-structure-variant-structure)))))) `,(var-structure-name str)) ,@(iter (for slot in (var-structure-slots str)) - (collect `(,(var-structure-slot-name slot) - ,(var-structure-slot-initform slot)))))) + (collect `(,(cstruct-slot-description-name slot) + ,(cstruct-slot-description-initform slot)))))) (defun generate-structures (str) (iter (for variant in (reverse (all-structures str))) @@ -340,22 +380,19 @@ (defun generate-native-type-decision-procedure-1 (str proxy-var) (if (null (var-structure-discriminator-slot str)) - `(values ',(generated-cstruct-name (var-structure-name str)) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))) + `(values ',(var-structure-resulting-cstruct-description str)) `(typecase ,proxy-var ,@(iter (for variant in (var-structure-variants str)) (for v-str = (var-structure-variant-structure variant)) (collect `(,(var-structure-name v-str) ,(generate-native-type-decision-procedure-1 v-str proxy-var)))) (,(var-structure-name str) - (values ',(generated-cstruct-name (var-structure-name str)) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))))))) + (values ',(var-structure-resulting-cstruct-description str)))))) (defun generate-proxy-type-decision-procedure-1 (str native-var) (if (null (var-structure-discriminator-slot str)) `(values ',(var-structure-name str) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)) - ',(generated-cstruct-name (var-structure-name str))) + ',(var-structure-resulting-cstruct-description str)) `(case (foreign-slot-value ,native-var ',(generated-cstruct-name (var-structure-name str)) ',(var-structure-discriminator-slot str)) @@ -366,17 +403,18 @@ v-str native-var)))) (t (values ',(var-structure-name str) - ',(mapcar #'var-structure-slot-name (var-struct-all-slots str)) - ',(generated-cstruct-name (var-structure-name str))))))) + ',(var-structure-resulting-cstruct-description str)))))) (defun generate-proxy-type-decision-procedure (str) (let ((native (gensym "NATIVE-"))) `(lambda (,native) + (declare (ignorable ,native)) ,(generate-proxy-type-decision-procedure-1 str native)))) (defun generate-native-type-decision-procedure (str) (let ((proxy (gensym "PROXY-"))) `(lambda (,proxy) + (declare (ignorable ,proxy)) ,(generate-native-type-decision-procedure-1 str proxy)))) (defun compile-proxy-type-decision-procedure (str) @@ -393,7 +431,7 @@ (defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env) (make-load-form-saving-slots object :environment env)) -(define-foreign-type boxed-variant-cstruct-foreign-type () ()) +(define-foreign-type boxed-variant-cstruct-foreign-type (g-boxed-foreign-type) ()) (defmethod make-foreign-type ((info g-boxed-variant-cstruct-info) &key return-p) (make-instance 'boxed-variant-cstruct-foreign-type :info info :return-p return-p)) @@ -401,7 +439,7 @@ (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) + ,(generate-variant-union structure) ,@(generate-structures structure) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) @@ -421,8 +459,8 @@ (defmethod boxed-copy-fn ((info g-boxed-variant-cstruct-info) native) (if (g-boxed-info-g-type info) (g-boxed-copy (g-boxed-info-g-type info) native) - (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)))) + (let ((copy (foreign-alloc (generated-cunion-name (g-boxed-info-name info))))) + (memcpy copy native (foreign-type-size (generated-cunion-name (g-boxed-info-name info)))) copy))) (defmethod boxed-free-fn ((info g-boxed-variant-cstruct-info) native) @@ -433,15 +471,13 @@ (defmethod translate-to-foreign (proxy (foreign-type boxed-variant-cstruct-foreign-type)) (if (null proxy) (null-pointer) - (let ((type (g-boxed-foreign-info foreign-type))) - (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy) - (with-foreign-object (native-structure (generated-cstruct-name - (var-structure-name - (g-boxed-variant-cstruct-info-root type)))) - (iter (for slot in slots) - (setf (foreign-slot-value native-structure actual-cstruct slot) - (slot-value proxy slot))) - (values (boxed-copy-fn type native-structure) proxy)))))) + (let* ((type (g-boxed-foreign-info foreign-type)) + (cstruct-description (decide-native-type type proxy))) + (with-foreign-object (native-structure (generated-cunion-name + (var-structure-name + (g-boxed-variant-cstruct-info-root type)))) + (copy-slots-to-native proxy native-structure cstruct-description) + (values (boxed-copy-fn type native-structure) proxy))))) (defun decide-proxy-type (info native-structure) (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure)) @@ -449,33 +485,30 @@ (defmethod free-translated-object (native (foreign-type boxed-variant-cstruct-foreign-type) proxy) (when proxy (let ((type (g-boxed-foreign-info foreign-type))) - (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native) + (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native) (unless (eq (type-of proxy) actual-struct) (restart-case (error "Expected type of boxed variant structure ~A and actual type ~A do not match" (type-of proxy) actual-struct) (skip-parsing-values () (return-from free-translated-object)))) - (iter (for slot in slots) - (setf (slot-value proxy slot) - (foreign-slot-value native actual-cstruct slot))))))) + (copy-slots-to-proxy proxy native cstruct-description) + (boxed-free-fn type native))))) -(defmethod translate-from-foreign (native (foreign-type g-boxed-variant-cstruct-info)) +(defmethod translate-from-foreign (native (foreign-type boxed-variant-cstruct-foreign-type)) (unless (null-pointer-p native) (let ((type (g-boxed-foreign-info foreign-type))) - (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native) + (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native) (let ((proxy (make-instance actual-struct))) - (iter (for slot in slots) - (setf (slot-value proxy slot) - (foreign-slot-value native actual-cstruct slot))) + (copy-slots-to-proxy proxy native cstruct-description) + (when (g-boxed-foreign-return-p foreign-type) + (boxed-free-fn type native)) proxy))))) -(defmethod cleanup-translated-object-for-callback ((foreign-type g-boxed-variant-cstruct-info) proxy native) +(defmethod cleanup-translated-object-for-callback ((foreign-type boxed-variant-cstruct-foreign-type) proxy native) (when proxy (let ((type (g-boxed-foreign-info foreign-type))) - (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy) - (iter (for slot in slots) - (setf (foreign-slot-value native actual-cstruct slot) - (slot-value proxy slot))))))) + (let ((cstruct-description (decide-native-type type proxy))) + (copy-slots-to-native proxy native cstruct-description))))) (defgeneric boxed-parse-g-value (gvalue-ptr info)) @@ -485,13 +518,13 @@ (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))) + (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr)))) (boxed-parse-g-value gvalue-ptr boxed-type)))) (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))) + (let ((boxed-type (get-g-boxed-foreign-info-for-gtype (g-value-type gvalue-ptr)))) (boxed-set-g-value gvalue-ptr boxed-type value)))) (defmethod boxed-parse-g-value (gvalue-ptr (info g-boxed-cstruct-wrapper-info)) @@ -511,3 +544,43 @@ (defmethod boxed-set-g-value (gvalue-ptr (info g-boxed-opaque-wrapper-info) proxy) (g-value-set-boxed gvalue-ptr (translate-to-foreign proxy (make-foreign-type info :return-p nil)))) + +(defun boxed-related-symbols (name) + (let ((info (get-g-boxed-foreign-info name))) + (etypecase info + (g-boxed-cstruct-wrapper-info + (append (list name + (intern (format nil "MAKE-~A" (symbol-name name))) + (intern (format nil "COPY-~A" (symbol-name name)))) + (iter (for slot in (cstruct-description-slots (g-boxed-cstruct-wrapper-info-cstruct-description info))) + (for slot-name = (cstruct-slot-description-name slot)) + (collect (intern (format nil "~A-~A" (symbol-name name) (symbol-name slot-name))))))) + (g-boxed-opaque-wrapper-info + (list name)) + (g-boxed-variant-cstruct-info + (append (list name) + (iter (for var-struct in (all-structures (g-boxed-variant-cstruct-info-root info))) + (for s-name = (var-structure-name var-struct)) + (for cstruct-description = (var-structure-resulting-cstruct-description var-struct)) + (appending (append (list (intern (format nil "MAKE-~A" (symbol-name s-name))) + (intern (format nil "COPY-~A" (symbol-name s-name)))) + (iter (for slot in (cstruct-description-slots cstruct-description)) + (for slot-name = (cstruct-slot-description-name slot)) + (collect (intern (format nil "~A-~A" (symbol-name s-name) + (symbol-name slot-name))))))))))))) + +(defmacro define-boxed-opaque-accessor (boxed-name accessor-name &key type reader writer) + (let ((var (gensym)) + (n-var (gensym))) + `(progn ,@(when reader + (list (etypecase reader + (symbol `(defun ,accessor-name (,var) + (funcall ,reader ,var))) + (string `(defcfun (,accessor-name ,reader) ,type + (,var (g-boxed-foreign ,boxed-name))))))) + ,@(when writer + (list (etypecase reader + (symbol `(defun (setf ,accessor-name) (,n-var ,var) + (funcall ,reader ,n-var ,var))) + (string `(defun (setf ,accessor-name) (,n-var ,var) + (foreign-funcall ,writer (g-boxed-foreign ,boxed-name) ,var ,type ,n-var :void)))))))))