(: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))
+(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)
: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))
(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))
(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))))
(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))
(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))
(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)
: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" (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)))))
-
-(defun generated-fn-name (symbol)
- (or (get symbol 'generated-fn-name)
- (setf (get symbol 'generated-fn-name) (gentemp (format nil "FN~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
+ (intern (format nil "~A-CUNION" (symbol-name symbol)) (symbol-package symbol)))
(defun generate-cstruct-1 (struct)
`(defcstruct ,(generated-cstruct-name (cstruct-description-name struct))
,(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)))
(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))
(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)))
+ (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))
(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))))
projects / cl-gtk2.git / blobdiff