(: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))
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)
(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
(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
: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))
(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 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))
(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) (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))))))
(defmethod translate-to-foreign (proxy (type boxed-cstruct-foreign-type))
(if (null proxy)
(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))
: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))
(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
(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 (cstruct-description-name struct))
(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)
- `(,(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)))
(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 #'cstruct-slot-description-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 #'cstruct-slot-description-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 #'cstruct-slot-description-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))
v-str
native-var))))
(t (values ',(var-structure-name str)
- ',(mapcar #'cstruct-slot-description-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)
(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)
(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)
(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))
(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 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)
- (let ((proxy (make-instance actual-struct)))
- (iter (for slot in slots)
- (setf (slot-value proxy slot)
- (foreign-slot-value native actual-cstruct slot)))
+ (multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
+ (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))
proxy)))))
(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))
(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))
(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)))))))))
projects / cl-gtk2.git / blobdiff