X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.boxed.lisp;h=34542b2bb2828a562359f3fabde4f4f8ab0e9c4d;hb=eee03aae86b30336ec34b468624e07adf2592b5e;hp=61eacee2f46d5c9024276ee89258912b5150f21f;hpb=68c63e655ca55742bb601229d01b72df2ac9bda3;p=cl-gtk2.git diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp index 61eacee..34542b2 100644 --- a/glib/gobject.boxed.lisp +++ b/glib/gobject.boxed.lisp @@ -35,14 +35,14 @@ (:method (type-info native) (g-boxed-copy (g-boxed-info-g-type type-info) native))) -(defmethod boxed-copy-fn :before (type-info native) +#+nil(defmethod boxed-copy-fn :before (type-info native) (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native)) (defgeneric boxed-free-fn (type-info native) (:method (type-info native) (g-boxed-free (g-boxed-info-g-type type-info) native))) -(defmethod boxed-free-fn :before (type-info native) +#+nil(defmethod boxed-free-fn :before (type-info native) (format t "(boxed-free-fn ~A ~A)~%" (g-boxed-info-name type-info) native)) (defmethod has-callback-cleanup ((type g-boxed-foreign-type)) @@ -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 @@ -100,7 +112,9 @@ :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)))))) + (get ',name 'g-boxed-foreign-info) + (get ',name 'structure-constructor) + ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name))))))) (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)) @@ -133,10 +147,20 @@ (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 create-structure (structure-name) + (let ((constructor (get structure-name 'structure-constructor))) + (assert constructor nil "Don't know how to create structure of type ~A" structure-name) + (funcall constructor))) + (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)) @@ -149,6 +173,12 @@ (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) (create-structure (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)))))) @@ -171,7 +201,7 @@ (unless (null-pointer-p native-structure) (let* ((info (g-boxed-foreign-info type)) (proxy-structure-type (g-boxed-info-name info)) - (proxy (make-instance proxy-structure-type))) + (proxy (create-structure proxy-structure-type))) (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)) @@ -193,6 +223,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)) @@ -220,15 +253,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 @@ -312,15 +343,11 @@ :structure (parse-variant-structure-definition variant-name slots parent))) (collect variant))) -(defpackage :gobject.boxed.generated-names) - (defun generated-cstruct-name (symbol) - (or (get symbol 'generated-cstruct-name) - (setf (get symbol 'generated-cstruct-name) (gentemp (format nil "CSTRUCT-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names))))) + (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) (gentemp (format nil "CUNION-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names))))) + (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol))) (defun generate-cstruct-1 (struct) `(defcstruct ,(generated-cstruct-name (cstruct-description-name struct)) @@ -341,18 +368,22 @@ ,(generated-cstruct-name (var-structure-name str))))))) (defun generate-structure-1 (str) - `(defstruct ,(if (var-structure-parent str) - `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str)) - (,(var-structure-discriminator-slot (var-structure-parent str)) - ,(first (var-structure-variant-discriminating-values - (find str - (var-structure-variants - (var-structure-parent str)) - :key #'var-structure-variant-structure)))))) - `,(var-structure-name str)) - ,@(iter (for slot in (var-structure-slots str)) - (collect `(,(cstruct-slot-description-name slot) - ,(cstruct-slot-description-initform slot)))))) + (let ((name (var-structure-name str))) + `(progn + (defstruct ,(if (var-structure-parent str) + `(,(var-structure-name str) (:include ,(var-structure-name (var-structure-parent str)) + (,(var-structure-discriminator-slot (var-structure-parent str)) + ,(first (var-structure-variant-discriminating-values + (find str + (var-structure-variants + (var-structure-parent str)) + :key #'var-structure-variant-structure)))))) + `,(var-structure-name str)) + ,@(iter (for slot in (var-structure-slots str)) + (collect `(,(cstruct-slot-description-name slot) + ,(cstruct-slot-description-initform slot))))) + (setf (get ',name 'structure-constructor) + ',(intern (format nil "MAKE-~A" (symbol-name name)) (symbol-package name)))))) (defun generate-structures (str) (iter (for variant in (reverse (all-structures str))) @@ -453,7 +484,7 @@ (null-pointer) (let* ((type (g-boxed-foreign-info foreign-type)) (cstruct-description (decide-native-type type proxy))) - (with-foreign-object (native-structure (generated-cstruct-name + (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) @@ -478,7 +509,7 @@ (unless (null-pointer-p native) (let ((type (g-boxed-foreign-info foreign-type))) (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native) - (let ((proxy (make-instance actual-struct))) + (let ((proxy (create-structure actual-struct))) (copy-slots-to-proxy proxy native cstruct-description) (when (g-boxed-foreign-return-p foreign-type) (boxed-free-fn type native)) @@ -498,13 +529,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)) @@ -524,3 +555,44 @@ (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 s-name) + (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)))))))))