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
(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))))
+ (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)
: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) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
+ (setf (get symbol 'generated-cstruct-name) (gentemp (format nil "CSTRUCT-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
(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))))))
+ (setf (get symbol 'generated-cunion-name) (gentemp (format nil "CUNION-~A" (symbol-name symbol)) (find-package :gobject.boxed.generated-names)))))
(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)
(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)
(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)
(when proxy
(let ((type (g-boxed-foreign-info foreign-type)))
(multiple-value-bind (actual-struct cstruct-description) (decide-proxy-type type native)
- (unless (eq (type-of proxy) (cstruct-description-name actual-struct))
+ (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))))
- (copy-slots-to-proxy proxy native cstruct-description)))))
+ (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)
projects / cl-gtk2.git / blobdiff