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 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))))))
(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) (make-instance (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))))))
: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
: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))
(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)
(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