X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=glib%2Fgobject.boxed.lisp;h=12f4cdadbe21f5f254fae42c8ee1c4fca096bede;hb=6950e782a8e1d7aea44e29cc25ba070d913642b0;hp=82023d4d81a1c45e85a326dd5ed5daa1b9f5bd06;hpb=f5db9ba8c281b54fc5dde3d3bb024a0f86c77ec3;p=cl-gtk2.git diff --git a/glib/gobject.boxed.lisp b/glib/gobject.boxed.lisp index 82023d4..12f4cda 100644 --- a/glib/gobject.boxed.lisp +++ b/glib/gobject.boxed.lisp @@ -21,8 +21,8 @@ (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)))) + (or (gethash (gtype-name (gtype g-type-designator)) *g-type-name->g-boxed-foreign-info*) + (error "Unknown GBoxed type '~A'" (gtype-name (gtype g-type-designator))))) (defgeneric make-foreign-type (info &key return-p)) @@ -38,13 +38,16 @@ #+nil(defmethod boxed-copy-fn :before (type-info native) (format t "(boxed-copy-fn ~A ~A)~%" (g-boxed-info-name type-info) native)) -#+nil(defgeneric boxed-free-fn (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)) +(defgeneric has-callback-cleanup (foreign-type)) +(defgeneric cleanup-translated-object-for-callback (foreign-type converted-object native-object)) + (defmethod has-callback-cleanup ((type g-boxed-foreign-type)) t) @@ -91,28 +94,34 @@ :slots (mapcar #'parse-cstruct-slot slots))) (defmacro define-g-boxed-cstruct (name g-type-name &body slots) - (let ((cstruct-description (parse-cstruct-definition name slots))) + (let ((cstruct-description (parse-cstruct-definition name slots)) + (cstruct-name (generated-cstruct-name name)) + (cunion-name (generated-cunion-name name))) `(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) + (defcstruct ,cstruct-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)))))) - (defcunion ,(generated-cunion-name name) - (,name ,(generated-cstruct-name name))) + (defctype ,cstruct-name (:struct ,cstruct-name)) + (defcunion ,cunion-name + (,name ,cstruct-name)) + (defctype ,cunion-name (:union ,cunion-name)) (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)))))) + (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)) @@ -154,6 +163,11 @@ (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)) @@ -168,7 +182,7 @@ (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))) + (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)))) @@ -194,7 +208,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)) @@ -223,23 +237,51 @@ (make-instance 'boxed-opaque-foreign-type :info info :return-p return-p)) (defmethod translate-to-foreign (proxy (type boxed-opaque-foreign-type)) - (prog1 (g-boxed-opaque-pointer proxy) - (when (g-boxed-foreign-return-p type) - (tg:cancel-finalization proxy) - (setf (g-boxed-opaque-pointer proxy) nil)))) + (if (null proxy) + (null-pointer) + (prog1 (g-boxed-opaque-pointer proxy) + (when (g-boxed-foreign-return-p type) + (tg:cancel-finalization proxy) + (setf (g-boxed-opaque-pointer proxy) nil))))) (defmethod free-translated-object (native (type boxed-opaque-foreign-type) param) (declare (ignore native type param))) +(defvar *gboxed-gc-hooks-lock* (make-recursive-lock "gboxed-gc-hooks-lock")) +(defvar *gboxed-gc-hooks* nil);;pointers to objects to be freed + +(defun activate-gboxed-gc-hooks () + (with-recursive-lock-held (*gboxed-gc-hooks-lock*) + (when *gboxed-gc-hooks* + (log-for :gc "activating gc hooks for boxeds: ~A~%" *gboxed-gc-hooks*) + (loop + for (pointer type) in *gboxed-gc-hooks* + do (boxed-free-fn type pointer)) + (setf *gboxed-gc-hooks* nil)))) + +(defcallback gboxed-idle-gc-hook :boolean ((data :pointer)) + (declare (ignore data)) + (activate-gboxed-gc-hooks) + nil) + +(defun register-gboxed-for-gc (type pointer) + (with-recursive-lock-held (*gboxed-gc-hooks-lock*) + (let ((locks-were-present (not (null *gboxed-gc-hooks*)))) + (push (list pointer type) *gboxed-gc-hooks*) + (unless locks-were-present + (log-for :gc "adding gboxed idle-gc-hook to main loop~%") + (g-idle-add (callback gboxed-idle-gc-hook) (null-pointer)))))) + (defun make-boxed-free-finalizer (type pointer) - (lambda () (boxed-free-fn type pointer))) + (lambda () (register-gboxed-for-gc type pointer))) (defmethod translate-from-foreign (native (foreign-type boxed-opaque-foreign-type)) (let* ((type (g-boxed-foreign-info foreign-type)) (proxy (make-instance (g-boxed-info-name type) :pointer native))) - (tg:finalize proxy (make-boxed-free-finalizer type native)))) + proxy)) (defmethod cleanup-translated-object-for-callback ((type boxed-opaque-foreign-type) proxy native) + (declare (ignore native)) (tg:cancel-finalization proxy) (setf (g-boxed-opaque-pointer proxy) nil)) @@ -328,8 +370,7 @@ (list thing))) (defun parse-variants (parent variants) - (iter (for var-descr in variants) - (for (options variant-name . slots) in variants) + (iter (for (options variant-name . slots) in variants) (for variant = (make-var-structure-variant :discriminating-values (ensure-list options) @@ -337,42 +378,50 @@ (collect variant))) (defun generated-cstruct-name (symbol) - (intern (format nil "~A-CSTRUCT-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol))) + (intern (format nil "~A-CSTRUCT" (symbol-name symbol)) (symbol-package symbol))) (defun generated-cunion-name (symbol) - (intern (format nil "~A-CUNION-GENERATED-BY-GOBJECT-BOXED" (symbol-name symbol)) (symbol-package symbol))) + (intern (format nil "~A-CUNION" (symbol-name symbol)) (symbol-package symbol))) (defun generate-cstruct-1 (struct) - `(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)))))))) + (let ((cstruct-name (generated-cstruct-name (cstruct-description-name struct)))) + `((defcstruct ,cstruct-name + ,@(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))))))) + (defctype ,cstruct-name (:struct ,cstruct-name))))) (defun generate-c-structures (structure) (iter (for str in (all-structures structure)) (for cstruct = (var-structure-resulting-cstruct-description str)) - (collect (generate-cstruct-1 cstruct)))) + (nconcing (generate-cstruct-1 cstruct)))) (defun generate-variant-union (struct) - `(defcunion ,(generated-cunion-name (var-structure-name struct)) - ,@(iter (for str in (all-structures struct)) - (collect `(,(var-structure-name str) - ,(generated-cstruct-name (var-structure-name str))))))) + (let ((cunion-name (generated-cunion-name (var-structure-name struct)))) + `((defcunion ,cunion-name + ,@(iter (for str in (all-structures struct)) + (collect `(,(var-structure-name str) + ,(generated-cstruct-name (var-structure-name str)))))) + (defctype ,cunion-name (:union ,cunion-name))))) (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))) @@ -439,7 +488,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-variant-union structure) + ,@(generate-variant-union structure) ,@(generate-structures structure) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'g-boxed-foreign-info) @@ -498,7 +547,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)) @@ -514,14 +563,14 @@ (defgeneric boxed-set-g-value (gvalue-ptr info proxy)) -(defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-boxed+)) parse-kind) +(defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql (gtype +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 (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) +(defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql (gtype +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 (g-value-type gvalue-ptr)))) @@ -585,3 +634,46 @@ (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))))))))) + +(defun copy-boxed-slots-to-foreign (structure native-ptr &optional (type (and structure (type-of structure)))) + (when structure + (copy-slots-to-native + structure + native-ptr + (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info type))))) + +(define-compiler-macro copy-boxed-slots-to-foreign (&whole whole structure native-ptr &optional type) + (if (and type + (constantp type)) + (let* ((type-r (eval type)) + (f-i (get-g-boxed-foreign-info type-r))) + (unless f-i + (warn "Unknown foreign GBoxed type ~S" type-r) + (return-from copy-boxed-slots-to-foreign whole)) + (unless (typep f-i 'g-boxed-cstruct-wrapper-info) + (warn "Foreign GBoxed type ~S is not a C structure wrapper" type-r) + (return-from copy-boxed-slots-to-foreign whole)) + `(when ,structure + (copy-slots-to-native + ,structure + ,native-ptr + (load-time-value (g-boxed-cstruct-wrapper-info-cstruct-description (get-g-boxed-foreign-info ',type-r)))))) + whole)) + +(defmacro with-foreign-boxed-array ((n-var array-var type values-seq) &body body) + (let ((values-seq-1 (gensym "VALUES-SEQ-")) + (cstruct (generated-cstruct-name type)) + (x (gensym "X-")) + (i (gensym "I-"))) + `(let* ((,values-seq-1 ,values-seq) + (,n-var (length ,values-seq-1))) + (with-foreign-object (,array-var ',cstruct ,n-var) + (let ((,i 0)) + (map nil (lambda (,x) + (copy-boxed-slots-to-foreign + ,x + (inc-pointer ,array-var (* ,i (foreign-type-size ',cstruct))) + ',type) + (incf ,i)) + ,values-seq-1)) + ,@body))))