*.lib
bugs/html/
*.lx64fsl
+tmp
+++ /dev/null
-1) GBoxed - это структуры, у которых нет идентичности
-2) При передаче ссылок, ссылки всегда имеют ограниченное время действия
-3) Структуры могут быть открытыми и закрытыми (opaque)
-
-Основной критерий: лисповский код не должен заботиться о владении структурами. Идентичности нет.
-
-Следствия:
-1) Все GBoxed, созданные в лиспе, удаляются только лиспом (при необходимости делается копия)
-2) Если foreign-функции возвращают GBoxed, то им владеет лисп (при необходимости делается копия)
-3) В callback'и возможна передача по ссылке (в том случае, если не знаем, как присвоить значение исходной структуре);
-в этом случае после выхода из callback'а лисповский прокси помечается как невалидный и операции с ним приводят к исключению
-
-Для реализации надо, чтобы CFFI позволяло совершать действия по очистке в конце callback'а.
-
-Код:
-
-(defclass g-boxed-type ()
- ((g-type-designator :initarg :g-type
- :initform ":G-TYPE must be specified"
- :accessor g-boxed-type-type)))
-
-;;Some terminology:
-;; * native structure - a C structure in foreign memory that
-;; has the data and is expected to be passed/received by foreign functions
-;; * proxy - a Lisp object (class or a structure) that is
-;; equivalent to native structure (has the same data in it). Its lifetime is indefinite
-;; and it is not affected by foreign code.
-;; A proxy may (but not required to) contain pointer to its own copy of a
-;; native structure.
-;; * reference proxy - a proxy that is whose lifetime is equal to a duration
-;; of a callback. Reference proxies can only be used during a callback that created them.
-
-;(defgeneric create-proxy (type)
-; "Creates a new proxy of a specified TYPE.")
-
-(defgeneric create-proxy-for-native (type native-ptr)
- (:documentation "Creates a proxy that is initialized by data contained in native
-structured pointed to by NATIVE-PTR.
-
-Created proxy should not be linked to NATIVE-PTR and should have
-indefinite lifetime (until garbage collector collects it). Specifically,
-if proxy need a pointer to native structure, it should make a copy of
-a structure.
-
-If proxy requires finalization, finalizers should be added."))
-
-(defgeneric create-temporary-native (type proxy)
- (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
-that contains the same data that the PROXY contains and returns a pointer to it.
-
-This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric free-temporary-native (type proxy native-ptr)
- (:documentation "Frees the native structure that was previously created
-by CREATE-TEMPORARY-NATIVE for the same PROXY.
-
-Also reads data from native structure pointer to by NATIVE-PTR
-and sets the PROXY to contain the same data.
-
-This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric create-reference-proxy (type native-ptr)
- (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
-
-Reference proxy's lifetime is bound to duration of a callback. When the
-callback returns the reference proxy is declared invalid and operations on it are errors.
-
-This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
-
-(defgeneric free-reference-proxy (type proxy native-ptr)
- (:documentation "Frees a reference proxy PROXY previously created by call to
-CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
-reflected in native structure pointed to by NATIVE-PTR.
-
-After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
-operations on it should signal erros.
-
-This call is always paired by call to CREATE-REFERENCE-PROXY."))
-
-(define-foreign-type g-boxed-foreign ()
- ((g-type :initarg :g-type
- :initform (error ":G-TYPE must be specified")
- :reader g-boxed-foreign-g-type)
- (pass-type :initarg :pass-type
- :reader g-boxed-foreign-g-type
- :type (member :callback :normal)
- :initform :normal))
- (:actual-type :pointer))
-
-(defun g-boxed-foreign->boxed-type (type)
- nil)
-
-(defmethod translate-to-foreign (proxy (type g-boxed-foreign))
- (let* ((boxed-type (g-boxed-foreign->boxed-type type))
- (native-ptr (create-temporary-native boxed-type proxy)))
- (values native-ptr proxy)))
-
-(defmethod free-translated-object (native-ptr (type g-boxed-foreign) proxy)
- (let ((boxed-type (g-boxed-foreign->boxed-type type)))
- (free-temporary-native boxed-type proxy native-ptr)))
-
-(defmethod translate-from-foreign (native-ptr (type g-boxed-foreign))
- (let ((boxed-type (g-boxed-foreign->boxed-type type)))
- (ecase )
- (create-proxy-for-native boxed-type native-ptr)))
-
+++ /dev/null
-(in-package :gobject)
-
-(define-foreign-type g-boxed-foreign-type ()
- ((info :initarg :info
- :accessor g-boxed-foreign-info
- :initform (error "info must be specified"))
- (free-from-foreign :initarg :free-from-foreign
- :initform nil
- :accessor g-boxed-foreign-free-from-foreign)
- (free-to-foreign :initarg :free-to-foreign
- :initform nil
- :accessor g-boxed-foreign-free-to-foreign)
- (for-callback :initarg :for-callback
- :initform nil
- :accessor g-boxed-foreign-for-callback))
- (:actual-type :pointer))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defstruct g-boxed-info
- name
- g-type))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun get-g-boxed-foreign-info (name)
- (get name 'g-boxed-foreign-info)))
-
-(define-parse-method g-boxed-foreign (name &key free-from-foreign free-to-foreign for-callback)
- (let ((info (get-g-boxed-foreign-info name)))
- (assert info nil "Unknown foreign GBoxed type ~A" name)
- (make-instance 'g-boxed-foreign-type
- :info info
- :free-from-foreign free-from-foreign
- :free-to-foreign free-to-foreign
- :for-callback for-callback)))
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (defstruct (g-boxed-cstruct-wrapper-info (:include g-boxed-info))
- cstruct
- slots))
-
-(defmacro define-g-boxed-cstruct (name cstruct-name g-type-name &body slots)
- `(progn
- (defstruct ,name
- ,@(iter (for (name type &key initarg) in slots)
- (collect (list name initarg))))
- (defcstruct ,cstruct-name
- ,@(iter (for (name type &key initarg) in slots)
- (collect `(,name ,type))))
- (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 ',cstruct-name
- :slots ',(iter (for (name type &key initarg) in slots)
- (collect name)))))))
-
-(define-g-boxed-cstruct gdk-rectangle gdk-rectangle-cstruct "GdkRectangle"
- (x :int :initarg 0)
- (y :int :initarg 0)
- (width :int :initarg 0)
- (height :int :initarg 0))
-
-(defgeneric create-temporary-native (type proxy)
- (:documentation "Creates a native structure (or passes a pointer to copy contained in PROXY)
-that contains the same data that the PROXY contains and returns a pointer to it.
-
-This call is always paired by call to FREE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric free-temporary-native (type proxy native-ptr)
- (:documentation "Frees the native structure that was previously created
-by CREATE-TEMPORARY-NATIVE for the same PROXY.
-
-Also reads data from native structure pointer to by NATIVE-PTR
-and sets the PROXY to contain the same data.
-
-This call is always paired by call to CREATE-TEMPORARY-NATIVE and calls may be nested."))
-
-(defgeneric create-proxy-for-native (type native-ptr)
- (:documentation "Creates a proxy that is initialized by data contained in native
-structured pointed to by NATIVE-PTR.
-
-Created proxy should not be linked to NATIVE-PTR and should have
-indefinite lifetime (until garbage collector collects it). Specifically,
-if proxy need a pointer to native structure, it should make a copy of
-a structure.
-
-If proxy requires finalization, finalizers should be added."))
-
-(defgeneric create-reference-proxy (type native-ptr)
- (:documentation "Creates a reference proxy for a native structure pointed to by NATIVE-PTR.
-
-Reference proxy's lifetime is bound to duration of a callback. When the
-callback returns the reference proxy is declared invalid and operations on it are errors.
-
-This call is always paired by call to FREE-REFERENCE-PROXY and calls will not nest."))
-
-(defgeneric free-reference-proxy (type proxy native-ptr)
- (:documentation "Frees a reference proxy PROXY previously created by call to
-CREATE-REFERENCE-PROXY. This call should ensure that all changes on PROXY are
-reflected in native structure pointed to by NATIVE-PTR.
-
-After a call to FREE-REFERENCE-PROXY, PROXY is declared invalid and using it is an error,
-operations on it should signal erros.
-
-This call is always paired by call to CREATE-REFERENCE-PROXY."))
-
-(defmethod create-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy)
- (format t "create-temporary-native~%")
- (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
- (native-structure (foreign-alloc native-structure-type)))
- (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
- (setf (foreign-slot-value native-structure native-structure-type slot)
- (slot-value proxy slot)))
- native-structure))
-
-(defmethod free-temporary-native ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
- (format t "free-temporary-native~%")
- (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
- (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
- (setf (slot-value proxy slot)
- (foreign-slot-value native-structure native-structure-type slot))))
- (foreign-free native-structure))
-
-(defmethod create-proxy-for-native ((type g-boxed-cstruct-wrapper-info) native-structure)
- (format t "create-proxy-for-native~%")
- (let* ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type))
- (proxy (make-instance (g-boxed-info-name type))))
- (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
- (setf (slot-value proxy slot)
- (foreign-slot-value native-structure native-structure-type slot)))
- proxy))
-
-(defmethod create-reference-proxy ((type g-boxed-cstruct-wrapper-info) native-structure)
- (format t "create-reference-proxy~%")
- (create-proxy-for-native type native-structure))
-
-(defmethod free-reference-proxy ((type g-boxed-cstruct-wrapper-info) proxy native-structure)
- (format t "free-reference-proxy~%")
- (let ((native-structure-type (g-boxed-cstruct-wrapper-info-cstruct type)))
- (iter (for slot in (g-boxed-cstruct-wrapper-info-slots type))
- (setf (foreign-slot-value native-structure native-structure-type slot)
- (slot-value proxy slot)))))
-
-(defmethod translate-to-foreign (proxy (type g-boxed-foreign-type))
- (if proxy
- (let* ((info (g-boxed-foreign-info type)))
- (values (create-temporary-native info proxy) proxy))
- (null-pointer)))
-
-(defmethod free-translated-object (native-structure (type g-boxed-foreign-type) proxy)
- (when proxy
- (free-temporary-native (g-boxed-foreign-info type) proxy native-structure)))
-
-(defmethod translate-from-foreign (native-structure (type g-boxed-foreign-type))
- (unless (null-pointer-p native-structure)
- (let* ((info (g-boxed-foreign-info type)))
- (cond
- ((g-boxed-foreign-for-callback type)
- (create-reference-proxy info native-structure))
- ((or (g-boxed-foreign-free-to-foreign type)
- (g-boxed-foreign-free-from-foreign type))
- (error "Feature not yet handled"))
- (t (create-proxy-for-native info native-structure))))))
-
-(defmethod cleanup-translated-object-for-callback ((type g-boxed-foreign-type) proxy native-structure)
- (unless (null-pointer-p native-structure)
- (free-reference-proxy (g-boxed-foreign-info type) proxy native-structure)))
-
-(defmethod has-callback-cleanup ((type g-boxed-foreign-type))
- t)
-
-(defcallback incf-rectangle :void ((rectangle (g-boxed-foreign gdk-rectangle :for-callback t))
- (delta :int))
- (incf (gdk-rectangle-x rectangle) delta)
- (incf (gdk-rectangle-y rectangle) delta)
- (incf (gdk-rectangle-width rectangle) delta)
- (incf (gdk-rectangle-height rectangle) delta)
- (format t "~A~%" rectangle))
-
-(defun do-incf-rect (r &optional (delta 1))
- (foreign-funcall-pointer (callback incf-rectangle) ()
- (g-boxed-foreign gdk-rectangle) r
- :int delta
- :void)
- r)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defstruct (g-boxed-opaque-wrapper-info (:include g-boxed-info))
- alloc free))
-
-(defclass g-boxed-opaque ()
- ((pointer :initarg :pointer
- :initform nil
- :accessor g-boxed-opaque-pointer)))
-
-(defmethod create-temporary-native ((type g-boxed-opaque-wrapper-info) proxy)
- (declare (ignore type))
- (g-boxed-opaque-pointer proxy))
-
-(defmethod free-temporary-native ((type g-boxed-opaque-wrapper-info) proxy native-structure)
- (declare (ignore type proxy native-structure)))
-
-(defmethod create-reference-proxy ((type g-boxed-opaque-wrapper-info) native-structure)
- (make-instance (g-boxed-info-g-type type) :pointer native-structure))
-
-(defmethod free-reference-proxy ((type g-boxed-opaque-wrapper-info) proxy native-structure)
- (declare (ignore type native-structure))
- (setf (g-boxed-opaque-pointer proxy) nil))
-
-(defmethod create-proxy-for-native ((type g-boxed-opaque-wrapper-info) native-structure)
- (let* ((g-type (g-boxed-info-g-type type))
- (native-copy (g-boxed-copy g-type native-structure)))
- (flet ((finalizer () (g-boxed-free g-type native-copy)))
- (let ((proxy (make-instance (g-boxed-opaque-wrapper-info-g-type type) :pointer native-copy)))
- (tg:finalize proxy #'finalizer)
- proxy))))
-
-(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-")))
- `(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 () (g-boxed-free ,g-type-name ,native-copy)))
- (setf (g-boxed-opaque-pointer ,instance) ,native-copy)
- (finalize ,instance #',finalizer)))))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'g-boxed-foreign-info)
- (make-g-boxed-opaque-wrapper-info :name ',name
- :g-type ,g-type-name))))))
-
-(define-g-boxed-opaque gtk-tree-path "GtkTreePath"
- :alloc (let* ((native-structure (gtk-tree-path-new))
- (native-copy (g-boxed-copy "GtkTreePath" native-structure)))
- (gtk-tree-path-free native-structure)
- native-copy))
-
-(defcfun gtk-tree-path-new :pointer)
-
-(defcfun gtk-tree-path-free :void
- (gtk-tree-path :pointer))
-
-(defcfun gtk-tree-path-copy :pointer
- (gtk-tree-path :pointer))
-
-(defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int
- (path (g-boxed-foreign gtk-tree-path)))
-
-(defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int)
- (path (g-boxed-foreign gtk-tree-path)))
-
-(defcfun gtk-tree-path-append-index :void
- (path (g-boxed-foreign gtk-tree-path))
- (index :int))
-
-(defun tree-path-get-indices (path)
- (let ((n (%gtk-tree-path-get-depth path))
- (indices (%gtk-tree-path-get-indices path)))
- (loop
- for i from 0 below n
- collect (mem-aref indices :int i))))
+++ /dev/null
-(in-package :gobject)
-
-(defstruct var-structure
- name
- parent
- slots
- discriminator-slot
- variants)
-
-(defstruct var-structure-variant
- discriminating-values
- structure)
-
-(defstruct var-structure-slot
- name
- type
- initform
- count)
-
-(defmethod make-load-form ((object var-structure) &optional env)
- (make-load-form-saving-slots object :environment env))
-
-(defmethod make-load-form ((object var-structure-slot) &optional env)
- (make-load-form-saving-slots object :environment env))
-
-(defmethod make-load-form ((object var-structure-variant) &optional env)
- (make-load-form-saving-slots object :environment env))
-
-(defun var-struct-all-slots (struct)
- (when struct
- (append (var-struct-all-slots (var-structure-parent struct))
- (var-structure-slots struct))))
-
-(defun all-structures (structure)
- (append (iter (for variant in (var-structure-variants structure))
- (appending (all-structures (var-structure-variant-structure variant))))
- (list structure)))
-
-(defun parse-variant-structure-definition (name slots &optional parent)
- (iter (with result = (make-var-structure :name name
- :parent parent
- :slots nil
- :discriminator-slot nil
- :variants nil))
- (for slot in slots)
- (if (eq :variant (first slot))
- (progn
- (when (var-structure-discriminator-slot result)
- (error "Structure has more than one discriminator slot"))
- (setf (var-structure-discriminator-slot result) (second slot)
- (var-structure-variants result) (parse-variants result (nthcdr 2 slot))))
- (push (parse-slot slot) (var-structure-slots result)))
- (finally (setf (var-structure-slots result)
- (reverse (var-structure-slots result)))
- (return result))))
-
-(defun parse-slot (slot)
- (destructuring-bind (name type &key count initform) slot
- (make-var-structure-slot :name name :type type :count count :initform initform)))
-
-(defun parse-variants (parent variants)
- (iter (for var-descr in variants)
- (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)))
-
-
+++ /dev/null
-(in-package :gobject)
-
-(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))))))
-
-(defun generated-cunion-name (symbol)
- (or (get symbol 'generated-cunion-name)
- (setf (get symbol 'generated-cunion-name) (gensym (format nil "GEN-~A-CSTRUCT-" (symbol-name symbol))))))
-
-(defun generate-cstruct-1 (struct)
- `(defcstruct ,(generated-cstruct-name (var-structure-name struct))
- ,@(iter (for slot in (var-struct-all-slots struct))
- (collect `(,(var-structure-slot-name slot) ,(var-structure-slot-type slot)
- ,@(when (var-structure-slot-count slot)
- (list `(:count ,(var-structure-slot-count slot)))))))))
-
-(defun generate-c-structures (structure)
- (iter (for str in (all-structures structure))
- (collect (generate-cstruct-1 str))))
-
-(defun generate-union-1 (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))))
-
-(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 `(,(var-structure-slot-name slot)
- ,(var-structure-slot-initform slot))))))
-
-(defun generate-structures (str)
- (iter (for variant in (reverse (all-structures str)))
- (collect (generate-structure-1 variant))))
-
-(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 #'var-structure-slot-name (var-struct-all-slots 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 #'var-structure-slot-name (var-struct-all-slots str)))))))
-
-(defun generate-proxy-type-decision-procedure-1 (str native-var)
- (if (null (var-structure-discriminator-slot str))
- `(values ',(var-structure-name str)
- ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
- ',(generated-cstruct-name (var-structure-name str)))
- `(case (foreign-slot-value ,native-var
- ',(generated-cstruct-name (var-structure-name str))
- ',(var-structure-discriminator-slot str))
- ,@(iter (for variant in (var-structure-variants str))
- (for v-str = (var-structure-variant-structure variant))
- (collect `(,(var-structure-variant-discriminating-values variant)
- ,(generate-proxy-type-decision-procedure-1
- v-str
- native-var))))
- (t (values ',(var-structure-name str)
- ',(mapcar #'var-structure-slot-name (var-struct-all-slots str))
- ',(generated-cstruct-name (var-structure-name str)))))))
-
-(defun generate-proxy-type-decision-procedure (str)
- (let ((native (gensym "NATIVE-")))
- `(lambda (,native)
- ,(generate-proxy-type-decision-procedure-1 str native))))
-
-(defun generate-native-type-decision-procedure (str)
- (let ((proxy (gensym "PROXY-")))
- `(lambda (,proxy)
- ,(generate-native-type-decision-procedure-1 str proxy))))
-
-(defun compile-proxy-type-decision-procedure (str)
- (compile nil (generate-proxy-type-decision-procedure str)))
-
-(defun compile-native-type-decision-procedure (str)
- (compile nil (generate-native-type-decision-procedure str)))
-
-(defstruct (g-boxed-variant-cstruct-info (:include g-boxed-info))
- root
- native-type-decision-procedure
- proxy-type-decision-procedure)
-
-(defmethod make-load-form ((object g-boxed-variant-cstruct-info) &optional env)
- (make-load-form-saving-slots object :environment env))
-
-(defmacro define-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-structures structure)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'g-boxed-foreign-info)
- (make-g-boxed-variant-cstruct-info :name ',name
- :g-type ,g-type-name
- :root ,structure
- :native-type-decision-procedure
- ,(generate-native-type-decision-procedure structure)
- :proxy-type-decision-procedure
- ,(generate-proxy-type-decision-procedure structure)))))))
-
-(defun decide-native-type (info proxy)
- (funcall (g-boxed-variant-cstruct-info-native-type-decision-procedure info) proxy))
-
-(defmethod create-temporary-native ((type g-boxed-variant-cstruct-info) proxy)
- (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
- (let ((native-structure (foreign-alloc
- (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)))
- native-structure)))
-
-(defun decide-proxy-type (info native-structure)
- (funcall (g-boxed-variant-cstruct-info-proxy-type-decision-procedure info) native-structure))
-
-(defmethod free-temporary-native ((type g-boxed-variant-cstruct-info) proxy native-ptr)
- (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
- (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-temporary-native))))
- (iter (for slot in slots)
- (setf (slot-value proxy slot)
- (foreign-slot-value native-ptr actual-cstruct slot)))))
-
-(defmethod create-proxy-for-native ((type g-boxed-variant-cstruct-info) native-ptr)
- (multiple-value-bind (actual-struct slots actual-cstruct) (decide-proxy-type type native-ptr)
- (let ((proxy (make-instance actual-struct)))
- (iter (for slot in slots)
- (setf (slot-value proxy slot)
- (foreign-slot-value native-ptr actual-cstruct slot)))
- proxy)))
-
-(defmethod create-reference-proxy ((type g-boxed-variant-cstruct-info) native-ptr)
- (create-proxy-for-native type native-ptr))
-
-(defmethod free-reference-proxy ((type g-boxed-variant-cstruct-info) proxy native-ptr)
- (multiple-value-bind (actual-cstruct slots) (decide-native-type type proxy)
- (iter (for slot in slots)
- (setf (foreign-slot-value native-ptr actual-cstruct slot)
- (slot-value proxy slot)))))
+++ /dev/null
-(in-package :gobject)
-
-(define-boxed-variant-cstruct evt "evt"
- (type :int :initform 0)
- (time :uint :initform 0)
- (:variant type
- (0 evt-zero
- (x :double :initform 0.0d0)
- (y :double :initform 0.0d0))
- ((1 2 3) evt-multi
- (t2 :int :initform 0)
- (:variant t2
- (1 evt-single
- (item :uchar :initform 0))))))
-
-(defcallback test-evt (g-boxed-foreign evt)
- ((time :int) (e1 (g-boxed-foreign evt)))
- (print time)
- (print e1)
- (when e1
- (incf (evt-time e1) time))
- (make-evt-multi :time time :t2 123))
-
-(defun do-test-evt (e1 time)
- (let ((e2 (foreign-funcall-pointer (callback test-evt) () :int time (g-boxed-foreign evt) e1 (g-boxed-foreign evt))))
- (values e1 e2)))
+++ /dev/null
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (require :fiveam))
-
-(defpackage :mm-test
- (:use :cl :gtk :glib :gobject :iter :tg :5am))
-
-(in-package :mm-test)
-
-(defun get-object (ptr)
- (when (cffi:pointerp ptr) (setf ptr (cffi:pointer-address ptr)))
- (or (gethash ptr gobject::*foreign-gobjects-strong*)
- (gethash ptr gobject::*foreign-gobjects-weak*)))
-
-(defun do-gc ()
- (gc :full t)
- (gobject::activate-gc-hooks)
- (gethash 0 gobject::*foreign-gobjects-strong*)
- (gobject::activate-gc-hooks)
- (gc :full t)
- (gethash 0 gobject::*foreign-gobjects-weak*)
- (gobject::activate-gc-hooks)
- (gc :full t))
-
-(defun object-handlers (object)
- (when object
- (remove nil (gobject::g-object-signal-handlers object))))
-
-(defun print-refs-table (table &optional (stream *standard-output*))
- (iter (for (ptr object) in-hashtable table)
- (format stream "~A => ~A (~A refs~@[~*, floating~])~@[ handlers: ~A~]~%"
- ptr object (gobject::ref-count object)
- (gobject.ffi:g-object-is-floating (cffi:make-pointer ptr))
- (object-handlers object))))
-
-(defun print-refs (&optional (stream *standard-output*))
- (format stream "Strong:~%")
- (print-refs-table gobject::*foreign-gobjects-strong*)
- (format stream "Weak:~%")
- (print-refs-table gobject::*foreign-gobjects-weak*))
-
-(defun count-refs ()
- (+ (hash-table-count gobject::*foreign-gobjects-strong*)
- (hash-table-count gobject::*foreign-gobjects-weak*)))
-
-(defun print-sps (&optional (stream *standard-output*))
- (iter (initially (format stream "Stable pointers:~%"))
- (for v in-vector gobject::*registered-stable-pointers*)
- (for i from 0)
- (when v
- (format stream "~A => ~A~%" i v))
- (finally (format stream "~%"))))
-
-(defun print-hooks (&optional (stream *standard-output*))
- (format stream "~A~%" gobject::*gobject-gc-hooks*))
-
-(defun delete-refs ()
- (maphash (lambda (key value)
- (declare (ignore value))
- (remhash key gobject::*foreign-gobjects-strong*))
- gobject::*foreign-gobjects-strong*)
- (maphash (lambda (key value)
- (declare (ignore value))
- (remhash key gobject::*foreign-gobjects-weak*))
- gobject::*foreign-gobjects-weak*))
-
-(when nil (defvar *builder* (make-instance 'builder :from-string
- "
-<interface>
- <object class=\"GtkDialog\" id=\"dialog1\">
- </object>
-</interface>
-")))
-
-(setf gobject::*debug-stream* *standard-output*
- gobject::*debug-gc* t
- gobject::*debug-subclass* t)
-
-(defclass my-button (gtk:button) () (:metaclass gobject-class))
-
-(def-suite mm-tests)
-
-(defun run-all-tests ()
- (run! 'mm-tests))
-
-(in-suite mm-tests)
-
-(defmacro with-gc-same-counting (&body body)
- (let ((count (gensym)))
- (multiple-value-bind (body gc-count)
- (if (integerp (first body))
- (values (rest body) (first body))
- (values body 1))
- `(progn
- (gc :full t)
- (gobject::activate-gc-hooks)
- (count-refs)
- (let ((,count (count-refs)))
- (funcall (lambda () ,@body))
- (iter (repeat ,gc-count)
- (format t "gc'ing~%")
- (gc :full t)
- (gobject::activate-gc-hooks)
- (count-refs))
- (is (= ,count (count-refs))))))))
-
-(test test-1
- (with-gc-same-counting
- 2
- (make-instance 'my-button)))
-
-(test test-with-signal
- (with-gc-same-counting
- 2
- (let ((b (make-instance 'my-button)))
- (connect-signal b "clicked" (lambda (bb) (declare (ignore bb)) (print b)))
- nil)))
-
-(test test-repassing
- (with-gc-same-counting
- 2
- (let ((b (make-instance 'my-button)))
- (cffi:convert-from-foreign (pointer b) 'g-object)
- nil)))
-
-(test test-builder
- (with-gc-same-counting
- 5
- (let ((b (make-instance 'builder :from-string "<interface>
- <object class=\"GtkButton\" id=\"button1\">
- </object>
-</interface>")))
- (builder-get-object b "button1")
- (gc :full t)
- (gobject::activate-gc-hooks))
- nil))
-
-(test test-builder-with-signals
- (with-gc-same-counting
- 6
- (let ((b (make-instance 'builder :from-string "<interface>
- <object class=\"GtkButton\" id=\"button1\">
- </object>
-</interface>")))
- (let ((btn (builder-get-object b "button1")))
- (connect-signal btn "clicked" (lambda (bb) (declare (ignore bb)) (print btn))))
- (gc :full t)
- (gobject::activate-gc-hooks))
- nil))
-
-(defun make-builder (&optional return)
- (let* ((builder (make-instance 'gtk:builder
- :from-file (namestring (merge-pathnames "demo/demo1.ui" gtk-demo::*src-location*))))
- (text-view (builder-get-object builder "textview1"))
- (window (builder-get-object builder "window1")))
- (builder-connect-signals-simple
- builder
- `(("quit_cb"
- ,(lambda (&rest args)
- (print args)
- (object-destroy window)))))
- (when return builder)))
+++ /dev/null
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (asdf:oos 'asdf:load-op :gtk)
- (asdf:oos 'asdf:load-op :iterate)
- (asdf:oos 'asdf:load-op :metabang-bind)
- (use-package :cffi)
- (use-package :gobject)
- (use-package :iter)
- (use-package :bind))
-
-(define-g-boxed-class nil g-type-info ()
- (class-size :uint16 :initform 0)
- (base-init :pointer :initform (null-pointer))
- (base-finalize :pointer :initform (null-pointer))
- (class-init :pointer :initform (null-pointer))
- (class-finalize :pointer :initform (null-pointer))
- (class-data :pointer :initform (null-pointer))
- (instance-size :uint16 :initform 0)
- (n-preallocs :uint16 :initform 0)
- (instance-init :pointer :initform (null-pointer))
- (value-type :pointer :initform (null-pointer)))
-
-(defcfun (%g-type-register-static "g_type_register_static") gobject::g-type
- (parent-type gobject::g-type)
- (type-name :string)
- (info (g-boxed-ptr g-type-info))
- (flags gobject::g-type-flags))
-
-(defcfun (%g-type-regiser-static-simple "g_type_register_static_simple") gobject::g-type
- (parent-type gobject::g-type)
- (type-name :string)
- (class-size :uint)
- (class-init :pointer)
- (instance-size :uint)
- (instance-init :pointer)
- (flags gobject::g-type-flags))
-
-(define-g-boxed-class nil g-type-query ()
- (type gobject::g-type :initform 0)
- (name (:string :free-from-foreign nil :free-to-foreign nil) :initform (null-pointer))
- (class-size :uint :initform 0)
- (instance-size :uint :initform 0))
-
-(defcfun (%g-type-query "g_type_query") :void
- (type gobject::g-type)
- (query (g-boxed-ptr g-type-query :in-out)))
-
-(define-foreign-type g-quark ()
- ()
- (:actual-type :uint32)
- (:simple-parser g-quark))
-
-(defcfun g-quark-from-string :uint32
- (string :string))
-
-(defcfun g-quark-to-string (:string :free-from-foreign nil)
- (quark :uint32))
-
-(defmethod translate-to-foreign (string (type g-quark))
- (g-quark-from-string string))
-
-(defmethod translate-from-foreign (value (type g-quark))
- (g-quark-to-string value))
-
-(defvar *stable-pointers-to-symbols* (make-array 0 :adjustable t :fill-pointer t))
-
-(defun stable-pointer (symbol)
- (vector-push-extend symbol *stable-pointers-to-symbols*)
- (length *stable-pointers-to-symbols*))
-
-(defun deref-stable-pointer (p)
- (aref *stable-pointers-to-symbols* (1- p)))
-
-(defcfun g-type-set-qdata :void
- (type gobject::g-type)
- (quark g-quark)
- (data :pointer))
-
-(defcfun g-type-get-qdata :pointer
- (type gobject::g-type)
- (quark g-quark))
-
-(defun g-object-register-sub-type (name parent-type lisp-class)
- (let ((q (make-g-type-query)))
- (%g-type-query (gobject::ensure-g-type parent-type) q)
- (let ((new-type-id (%g-type-regiser-static-simple (gobject::ensure-g-type parent-type)
- name
- (g-type-query-class-size q)
- (null-pointer)
- (g-type-query-instance-size q)
- (null-pointer)
- nil)))
- (when (zerop new-type-id)
- (error "Type registration failed for ~A" name))
- (g-type-set-qdata new-type-id "lisp-class-name" (make-pointer (stable-pointer lisp-class)))
- (setf (get lisp-class 'g-type-name) name))))
-
-(defun g-type-lisp-class (type)
- (let ((sp (pointer-address (g-type-get-qdata (gobject::ensure-g-type type) "lisp-class-name"))))
- (when (zerop sp)
- (error "Type ~A is not a lisp-based type" type))
- (deref-stable-pointer sp)))
-
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun vtable-item->cstruct-item (member)
- (if (eq (first member) :skip)
- (second member)
- `(,(first member) :pointer)))
-
- (defun vtable->cstruct (table-name options members)
- (bind (((&key cstruct-name &allow-other-keys) options))
- `(defcstruct ,cstruct-name
- ,@(mapcar #'vtable-item->cstruct-item members))))
-
- (defun arg-name->name (name)
- (if (listp name)
- (second name)
- name))
-
- (defun arg->arg-name (arg)
- (arg-name->name (first arg)))
-
- (defun vtable-member->callback (table-name options member)
- (bind (((name return-type &rest args) member))
- `(defcallback ,name ,return-type ,args
- (funcall ',name ,@(mapcar #'arg->arg-name args)))))
-
- (defun vtable->callbacks (table-name options members)
- (mapcar (lambda (member) (vtable-member->callback table-name options member))
- (remove-if (lambda (member) (eq (first member) :skip)) members)))
-
- (defun vtable-member->init-member (iface-ptr-var table-name options member)
- (bind (((&key cstruct-name &allow-other-keys) options))
- `(setf (foreign-slot-value ,iface-ptr-var ',cstruct-name ',(first member))
- (callback ,(first member)))))
-
- (defun vtable->interface-init (table-name options members)
- (bind (((&key interface-initializer &allow-other-keys) options))
- `(defcallback ,interface-initializer :void ((iface :pointer) (data :pointer))
- (declare (ignore data))
- ,@(mapcar (lambda (member) (vtable-member->init-member 'iface table-name options member))
- (remove-if (lambda (member) (eq (first member) :skip)) members)))))
-
- (defun vtable-member->generic-function (table-name options member)
- (bind (((name return-type &rest arguments) member))
- `(defgeneric ,name (,@(mapcar #'first arguments)))))
-
- (defun vtable->generics-def (table-name options members)
- (mapcar (lambda (member) (vtable-member->generic-function table-name options member))
- (remove-if (lambda (member) (eq (first member) :skip)) members))))
-
-(defmacro define-vtable (name options &body members)
- `(progn
- ,(vtable->cstruct name options members)
- ,@(vtable->callbacks name options members)
- ,(vtable->interface-init name options members)
- ,@(vtable->generics-def name options members)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (get ',name 'options) ',options
- (get ',name 'members) ',members))))
-
-(define-g-flags "GtkTreeModelFlags" tree-model-flags (t)
- (:iters-persist 1) (:list-only 2))
-
-(define-g-boxed-class "GtkTreeIter" tree-iter ()
- (stamp :int)
- (user-data :pointer)
- (user-data-2 :pointer)
- (user-data-3 :pointer))
-
-(defctype tree-path :pointer)
-
-(define-vtable tree-model (:interface "GtkTreeModel" :class-name gtk-tree-model :cstruct-name gtk-tree-model-iface :interface-initializer gtk-tree-model-iface-init)
- (:skip (parent-instance gobject::g-type-interface))
- ;;some signals
- (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-deleted :void (tree-model :pointer) (path :pointer))
- (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer))
- ;;methods
- (tree-model-get-flags tree-model-flags (tree-model g-object))
- (tree-model-get-n-columns :int (tree-model g-object))
- (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int))
- (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path))
- (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value)))
- (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter)))
- (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)))
- (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int))
- (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter)))
- (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))))
-
-(defcfun g-type-add-interface-static :void
- (instance-type gobject::g-type)
- (interface-type gobject::g-type)
- (info (:pointer gobject::g-interface-info)))
-
-(defun add-interface (lisp-class vtable-name)
- (with-foreign-object (iface-info 'gobject::g-interface-info)
- (setf (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-init) (get-callback (getf (get vtable-name 'options) :interface-initializer))
- (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-finalize) (null-pointer)
- (foreign-slot-value iface-info 'gobject::g-interface-info 'gobject::interface-data) (null-pointer))
- (unless (getf (get vtable-name 'options) :interface)
- (error "Vtable ~A is not a vtable of an interface"))
- (g-type-add-interface-static (gobject::g-type-from-name (get lisp-class 'g-type-name))
- (gobject::g-type-from-name (getf (get vtable-name 'options) :interface))
- iface-info)))
-
-(defvar *o1* nil)
-(defvar *o2* nil)
-
-(unless *o1*
- (g-object-register-sub-type "LispTreeStore" "GObject" 'lisp-tree-store)
- (setf *o1* t))
-(unless *o2*
- (add-interface 'lisp-tree-store 'tree-model)
- (setf *o2* t))
-
-(defclass tree-model (g-object) ())
-(defmethod initialize-instance :before ((object tree-model) &key pointer)
- (unless pointer
- (setf (gobject::pointer object) (gobject::g-object-call-constructor (gobject::g-type-from-name "LispTreeStore") nil nil nil))))
-
-(defmethod tree-model-get-flags ((model tree-model))
- (list :list-only))
-
-(defmethod tree-model-get-n-columns ((model tree-model))
- 1)
-
-(defmethod tree-model-get-column-type ((model tree-model) index)
- (gobject::g-type-from-name "gchararray"))
-
-(defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int
- (path tree-path))
-
-(defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int)
- (path tree-path))
-
-(defcfun (%gtk-tree-path-new "gtk_tree_path_new") :pointer)
-
-(defcfun (%gtk-tree-path-append-index "gtk_tree_path_append_index") :void
- (path :pointer)
- (index :int))
-
-(defun tree-path-indices (path)
- (let ((n (%gtk-tree-path-get-depth path))
- (indices (%gtk-tree-path-get-indices path)))
- (loop
- for i from 0 below n
- collect (mem-aref indices :int i))))
-
-(defmethod tree-model-get-iter ((model tree-model) iter path)
- (let ((indices (tree-path-indices path)))
- (when (= 1 (length indices))
- (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter)
- (setf stamp 0 user-data (make-pointer (first indices)) user-data-2 (null-pointer) user-data-3 (null-pointer)))
- t)))
-
-(defmethod tree-model-ref-node ((model tree-model) iter))
-(defmethod tree-model-unref-node ((model tree-model) iter))
-
-(defmethod tree-model-iter-next ((model tree-model) iter)
- (with-foreign-slots ((stamp user-data) iter tree-iter)
- (let ((n (pointer-address user-data)))
- (when (< n 5)
- (setf user-data (make-pointer (1+ n)))
- t))))
-
-(defmethod tree-model-iter-nth-child ((model tree-model) iter parent n)
- (with-foreign-slots ((stamp user-data user-data-2 user-data-3) iter tree-iter)
- (setf stamp 0 user-data (make-pointer n) user-data-2 (null-pointer) user-data-3 (null-pointer)))
- t)
-
-(defmethod tree-model-iter-n-children ((model tree-model) iter)
- (if (null iter)
- 5
- 0))
-
-(defmethod tree-model-get-path ((model tree-model) iter)
- (let ((path (%gtk-tree-path-new)))
- (%gtk-tree-path-append-index path (pointer-address (tree-iter-user-data iter)))
- path))
-
-(defmethod tree-model-iter-has-child ((model tree-model) iter)
- nil)
-
-(defmethod tree-model-get-value ((model tree-model) iter n value)
- (let ((n-row (pointer-address (tree-iter-user-data iter))))
- (gobject::set-g-value value (format nil "~A" (expt n-row 2)) (gobject::g-type-from-name "gchararray"))))
-
-(defcfun (%gtk-tree-view-append-column "gtk_tree_view_append_column") :int
- (tree-view (g-object gtk:tree-view))
- (column (g-object gtk:tree-view-column)))
-
-(defcfun (%gtk-tree-view-column-pack-start "gtk_tree_view_column_pack_start") :void
- (tree-column (g-object gtk:tree-view-column))
- (cell (g-object gtk:cell-renderer))
- (expand :boolean))
-
-(defcfun (%gtk-tree-view-column-add-attribute "gtk_tree_view_column_add_attribute") :void
- (tree-column (g-object gtk:tree-view-column))
- (cell-renderer (g-object gtk:cell-renderer))
- (attribute :string)
- (column-number :int))
-
-(defun test-treeview ()
- (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "Treeview" :border-width 30))
- (model (make-instance 'tree-model))
- (tv (make-instance 'gtk:tree-view :model model :headers-visible t)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit)))
- (let ((column (make-instance 'gtk:tree-view-column :title "Number"))
- (renderer (make-instance 'gtk:cell-renderer-text :text "A text")))
- (%gtk-tree-view-column-pack-start column renderer t)
- (%gtk-tree-view-column-add-attribute column renderer "text" 0)
- (%gtk-tree-view-append-column tv column))
- (gtk:container-add window tv)
- (gtk:gtk-widget-show-all window)
- (gtk:gtk-main)))
-
-(defcfun (%gtk-cell-layout-pack-start "gtk_cell_layout_pack_start") :void
- (cell-layout g-object)
- (cell (g-object gtk:cell-renderer))
- (expand :boolean))
-
-(defcfun (%gtk-cell-layout-add-attribute "gtk_cell_layout_add_attribute") :void
- (cell-layout g-object)
- (cell (g-object gtk:cell-renderer))
- (attribute :string)
- (column :int))
-
-(defun test-combobox ()
- (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "cb" :border-width 30))
- (model (make-instance 'tree-model))
- (combobox (make-instance 'gtk:combo-box :model model)))
- (g-signal-connect window "destroy" (lambda (w) (declare (ignore w)) (gtk:gtk-main-quit)))
- (g-signal-connect combobox "changed" (lambda (w) (declare (ignore w)) (format t "Changed cb; active now = ~A~%" (gtk:combo-box-active combobox))))
- (let ((renderer (make-instance 'gtk:cell-renderer-text)))
- (%gtk-cell-layout-pack-start combobox renderer t)
- (%gtk-cell-layout-add-attribute combobox renderer "text" 0))
- (gtk:container-add window combobox)
- (gtk:gtk-widget-show-all window)
- (gtk:gtk-main)))
-
-(define-vtable widget (:class "GtkWidget" :cstruct-name widget-vtable :interface-initializer gtk-tree-model-iface-init)
- (:skip (parent-instance gobject::g-type-interface))
- ;;some signals
- (tree-model-row-changed :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-inserted :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-has-child-toggled :void (tree-model :pointer) (path :pointer) (iter :pointer))
- (tree-model-row-deleted :void (tree-model :pointer) (path :pointer))
- (tree-model-rows-reordered :void (tree-model :pointer) (path :pointer) (iter :pointer) (new-order :pointer))
- ;;methods
- (tree-model-get-flags tree-model-flags (tree-model g-object))
- (tree-model-get-n-columns :int (tree-model g-object))
- (tree-model-get-column-type gobject::g-type (tree-model g-object) (index :int))
- (tree-model-get-iter :boolean (tree-model g-object) (iter (:pointer tree-iter)) (path tree-path))
- (tree-model-get-path tree-path (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-get-value :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)) (n :int) (value (:pointer gobject::g-value)))
- (tree-model-iter-next :boolean (tree-model g-object) (iter (:pointer tree-iter)))
- (tree-model-iter-children :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)))
- (tree-model-iter-has-child :boolean (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-iter-n-children :int (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-iter-nth-child :boolean (tree-model g-object) (iter (:pointer tree-iter)) (parent (g-boxed-ptr tree-iter)) (n :int))
- (tree-model-iter-parent :boolean (tree-model g-object) (iter (:pointer tree-iter)) (child (g-boxed-ptr tree-iter)))
- (tree-model-ref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter)))
- (tree-model-unref-node :void (tree-model g-object) (iter (g-boxed-ptr tree-iter))))
\ No newline at end of file
+++ /dev/null
-(gobject:define-g-flags "GtkTreeModelFlags" tree-model-flags (:type-initializer "gtk_tree_model_flags_get_type")
- (:iters-persist 1) (:list-only 2))
-
-(cffi:defcstruct tree-iter
- (stamp :int)
- (user-data :pointer)
- (user-data-2 :pointer)
- (user-data-3 :pointer))
-
-(defun tree-iter-get-stamp (i) (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'stamp))
-(defun tree-iter-set-stamp (value i) (setf (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'stamp) value))
-(defun tree-iter-get-user-data (i) (cffi:pointer-address (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'user-data)))
-(defun tree-iter-set-user-data (value i) (setf (cffi:foreign-slot-value (gobject::pointer i) 'tree-iter 'user-data) (cffi:make-pointer value)))
-
-(defun tree-iter-alloc () (glib::g-malloc (cffi:foreign-type-size 'tree-iter)))
-(defun tree-iter-free (v) (glib::g-free v))
-
-(gobject:define-g-boxed-ref "GtkTreeIter" tree-iter
- (:slots (stamp :reader tree-iter-get-stamp :writer tree-iter-set-stamp :accessor tree-iter-stamp)
- (user-data :reader tree-iter-get-user-data :writer tree-iter-set-user-data :accessor tree-iter-user-data))
- (:alloc-function tree-iter-alloc)
- (:free-function tree-iter-free))
-
-(cffi:defctype tree-path :pointer)
-(cffi:defcfun (%gtk-tree-path-get-depth "gtk_tree_path_get_depth") :int
- (path tree-path))
-
-(cffi:defcfun (%gtk-tree-path-get-indices "gtk_tree_path_get_indices") (:pointer :int)
- (path tree-path))
-
-(cffi:defcfun (%gtk-tree-path-new "gtk_tree_path_new") :pointer)
-
-(cffi:defcfun (%gtk-tree-path-append-index "gtk_tree_path_append_index") :void
- (path :pointer)
- (index :int))
-
-(defun tree-path-get-indices (path)
- (setf path (gobject::pointer path))
- (let ((n (%gtk-tree-path-get-depth path))
- (indices (%gtk-tree-path-get-indices path)))
- (loop
- for i from 0 below n
- collect (cffi:mem-aref indices :int i))))
-
-(defun tree-path-set-indices (indices path)
- (setf path (gobject::pointer path))
- (loop
- repeat (%gtk-tree-path-get-depth path)
- do (cffi:foreign-funcall "gtk_tree_path_up" :pointer path :boolean))
- (loop
- for index in indices
- do(cffi:foreign-funcall "gtk_tree_path_append_index" :pointer path :int index :void)))
-
-(cffi:defcfun gtk-tree-path-new :pointer)
-(cffi:defcfun gtk-tree-path-free :void (path :pointer))
-
-(gobject::define-g-boxed-ref "GtkTreePath" tree-path
- (:alloc-function gtk-tree-path-new)
- (:free-function gtk-tree-path-free)
- (:slots (indices :reader tree-path-get-indices :writer tree-path-set-indices :accessor tree-path-indices)))
-
-(gobject::define-vtable ("GtkTreeModel" c-gtk-tree-model)
- (:skip parent-instance gobject::g-type-interface)
- ;;some signals
- (:skip tree-model-row-changed :pointer)
- (:skip tree-model-row-inserted :pointer)
- (:skip tree-model-row-has-child-toggled :pointer)
- (:skip tree-model-row-deleted :pointer)
- (:skip tree-model-rows-reordered :pointer)
- ;;methods
- (tree-model-get-flags-impl tree-model-get-flags-cb tree-model-flags (tree-model gobject:g-object))
- (tree-model-get-n-columns-impl tree-model-get-n-columns-cb :int (tree-model gobject:g-object))
- (tree-model-get-column-type-impl tree-model-get-column-type-cb gobject::g-type (tree-model gobject:g-object) (index :int))
- (tree-model-get-iter-impl tree-model-get-iter-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (path (gobject:g-boxed-ref tree-path)))
- (tree-model-get-path-impl tree-model-get-path-cb (gobject:g-boxed-ref tree-path) (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))
- (tree-model-get-value-impl tree-model-get-value-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (n :int) (value (:pointer gobject::g-value)))
- (tree-model-iter-next-impl tree-model-iter-next-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))
- (tree-model-iter-children-impl tree-model-iter-children-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (parent (gobject:g-boxed-ref tree-iter)))
- (tree-model-iter-has-child-impl tree-model-iter-has-child-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))
- (tree-model-iter-n-children-impl tree-model-iter-n-children-cb :int (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))
- (tree-model-iter-nth-child-impl tree-model-iter-nth-child-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (parent (gobject:g-boxed-ref tree-iter)) (n :int))
- (tree-model-iter-parent-impl tree-model-iter-parent-cb :boolean (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)) (child (gobject:g-boxed-ref tree-iter)))
- (tree-model-ref-node-impl tree-model-ref-node-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter)))
- (tree-model-unref-node-impl tree-model-unref-node-cb :void (tree-model gobject:g-object) (iter (gobject:g-boxed-ref tree-iter))))
-
-(defclass array-list-store (gobject:g-object gtk:tree-model)
- ((items :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-items)
- (columns-getters :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-getters)
- (columns-types :initform (make-array 0 :adjustable t :fill-pointer t) :reader store-types)))
-
-(gobject::register-object-type-implementation "LispArrayListStore" array-list-store "GObject" ("GtkTreeModel") nil)
-
-(defun store-add-item (store item)
- (vector-push-extend item (store-items store))
- (gobject:using* ((path (make-instance 'tree-path))
- (iter (make-instance 'tree-iter)))
- (setf (tree-path-indices path) (list (1- (length (store-items store)))))
- (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (1- (length (store-items store))))
- (gobject::emit-signal store "row-inserted" path iter)))
-
-(defun store-add-column (store type getter)
- (vector-push-extend (gobject::ensure-g-type type) (store-types store))
- (vector-push-extend getter (store-getters store))
- (1- (length (store-types store))))
-
-(defmethod tree-model-get-flags-impl ((model array-list-store))
- '(:list-only))
-
-(defmethod tree-model-get-n-columns-impl ((model array-list-store))
- (length (store-types model)))
-
-(defmethod tree-model-get-column-type-impl ((tree-model array-list-store) index)
- (aref (store-types tree-model) index))
-
-(defmethod tree-model-get-iter-impl ((model array-list-store) iter path)
- (gobject:using* (iter path)
- (let ((indices (tree-path-indices path)))
- (when (= 1 (length indices))
- (setf (tree-iter-stamp iter) 0 (tree-iter-user-data iter) (first indices))
- t))))
-
-(defmethod tree-model-ref-node-impl ((model array-list-store) iter) (gobject:release iter))
-(defmethod tree-model-unref-node-impl ((model array-list-store) iter) (gobject:release iter))
-
-(defmethod tree-model-iter-next-impl ((model array-list-store) iter)
- (gobject:using* (iter)
- (let ((n (tree-iter-user-data iter)))
- (when (< n (1- (length (store-items model))))
- (setf (tree-iter-user-data iter) (1+ n))
- t))))
-
-(defmethod tree-model-iter-nth-child-impl ((model array-list-store) iter parent n)
- (gobject:using* (iter parent)
- (setf (tree-iter-stamp iter) 0
- (tree-iter-user-data iter) n)
- t))
-
-(defmethod tree-model-iter-n-children-impl ((model array-list-store) iter)
- (if (cffi:null-pointer-p iter)
- (length (store-items model))
- 0))
-
-(defmethod tree-model-get-path-impl ((model array-list-store) iter)
- (gobject:using* (iter)
- (let ((path (make-instance 'tree-path)))
- (setf (tree-path-indices path) (list (tree-iter-user-data iter)))
- (gobject:disown-boxed-ref path)
- path)))
-
-(defmethod tree-model-iter-has-child-impl ((model array-list-store) iter)
- (gobject:release iter)
- nil)
-
-(defmethod tree-model-get-value-impl ((model array-list-store) iter n value)
- (gobject:using (iter)
- (let ((n-row (tree-iter-user-data iter)))
- (gobject::set-g-value value
- (funcall (aref (store-getters model) n)
- (aref (store-items model) n-row))
- (aref (store-types model) n)))))
-
-(cffi:defcfun (%gtk-tree-view-append-column "gtk_tree_view_append_column") :int
- (tree-view (gobject:g-object gtk:tree-view))
- (column (gobject:g-object gtk:tree-view-column)))
-
-(cffi:defcfun (%gtk-tree-view-column-pack-start "gtk_tree_view_column_pack_start") :void
- (tree-column (gobject:g-object gtk:tree-view-column))
- (cell (gobject:g-object gtk:cell-renderer))
- (expand :boolean))
-
-(cffi:defcfun (%gtk-tree-view-column-add-attribute "gtk_tree_view_column_add_attribute") :void
- (tree-column (gobject:g-object gtk:tree-view-column))
- (cell-renderer (gobject:g-object gtk:cell-renderer))
- (attribute :string)
- (column-number :int))
-
-(defstruct item title value)
-
-(defun test-treeview ()
- (let* ((window (make-instance 'gtk:gtk-window :type :toplevel :title "Treeview"))
- (model (make-instance 'array-list-store))
- (scroll (make-instance 'gtk:scrolled-window :hscrollbar-policy :automatic :vscrollbar-policy :automatic))
- (tv (make-instance 'gtk:tree-view :headers-visible t :width-request 100 :height-request 400))
- (h-box (make-instance 'gtk:h-box))
- (v-box (make-instance 'gtk:v-box))
- (title-entry (make-instance 'gtk:entry))
- (value-entry (make-instance 'gtk:entry))
- (button (make-instance 'gtk:button :label "Add")))
- (store-add-column model "gchararray" #'item-title)
- (store-add-column model "gint" #'item-value)
- (store-add-item model (make-item :title "Monday" :value 1))
- (store-add-item model (make-item :title "Tuesday" :value 2))
- (store-add-item model (make-item :title "Wednesday" :value 3))
- (store-add-item model (make-item :title "Thursday" :value 4))
- (store-add-item model (make-item :title "Friday" :value 5))
- (store-add-item model (make-item :title "Saturday" :value 6))
- (store-add-item model (make-item :title "Sunday" :value 7))
- (setf (gtk:tree-view-model tv) model)
- (gobject:g-signal-connect window "destroy" (lambda (w) (gobject:release w) (gtk:gtk-main-quit)))
- (gobject:g-signal-connect button "clicked" (lambda (b) (gobject:release b) (store-add-item model (make-item :title (gtk:entry-text title-entry)
- :value (parse-integer (gtk:entry-text value-entry)
- :junk-allowed t)))
- #+nil(setf (gtk:tree-view-model tv) nil)
- #+nil(setf (gtk:tree-view-model tv) model)))
- (gtk:container-add window v-box)
- (gtk:box-pack-start v-box h-box :expand nil)
- (gtk:box-pack-start h-box title-entry :expand nil)
- (gtk:box-pack-start h-box value-entry :expand nil)
- (gtk:box-pack-start h-box button :expand nil)
- (gtk:box-pack-start v-box scroll)
- (gtk:container-add scroll tv)
- (let ((column (make-instance 'gtk:tree-view-column :title "Title"))
- (renderer (make-instance 'gtk:cell-renderer-text :text "A text")))
- (%gtk-tree-view-column-pack-start column renderer t)
- (%gtk-tree-view-column-add-attribute column renderer "text" 0)
- (%gtk-tree-view-append-column tv column))
- (let ((column (make-instance 'gtk:tree-view-column :title "Value"))
- (renderer (make-instance 'gtk:cell-renderer-text :text "A text")))
- (%gtk-tree-view-column-pack-start column renderer t)
- (%gtk-tree-view-column-add-attribute column renderer "text" 1)
- (%gtk-tree-view-append-column tv column))
- (gtk:gtk-widget-show-all window)
- (gtk:gtk-main)))
\ No newline at end of file
+++ /dev/null
-(in-package :gobject)
-
-(define-g-boxed-cstruct rectangle "GdkRectangle"
- (left :int :initform 0)
- (top :int :initform 0)
- (width :int :initform 0)
- (height :int :initform 0))
-
-(at-init () (eval (type-initializer-call "gdk_rectangle_get_type")))
-
-(define-g-boxed-cstruct point nil
- (x :int :initform 0)
- (y :int :initform 0))
-
-(defun mem-copy (source destination count)
- (iter (for i from 0 below count)
- (setf (mem-aref destination :uchar i)
- (mem-aref source :uchar i))))
-
-(defmethod boxed-copy-fn ((type-info (eql (get 'point 'g-boxed-foreign-info))) native)
- (let ((native-copy (foreign-alloc (generated-cstruct-name (g-boxed-info-name type-info)))))
- (mem-copy native native-copy (foreign-type-size (generated-cstruct-name (g-boxed-info-name type-info))))
- native-copy))
-
-(defmethod boxed-free-fn ((type-info (eql (get 'point 'g-boxed-foreign-info))) native)
- (foreign-free native))
-
-(defcallback make-rect-cb (g-boxed-foreign rectangle :return)
- ((a (g-boxed-foreign point)) (b (g-boxed-foreign point)))
- (make-rectangle :left (min (point-x a) (point-x b))
- :top (min (point-y a) (point-y b))
- :width (abs (- (point-x a) (point-x b)))
- :height (abs (- (point-y a) (point-y b)))))
-
-(defun call-make-rect-cb (a b)
- (foreign-funcall-pointer (callback make-rect-cb) ()
- (g-boxed-foreign point) a
- (g-boxed-foreign point) b
- (g-boxed-foreign rectangle :return)))
-
-(define-g-boxed-cstruct vector4 nil
- (coords :double :count 4 :initform (vector 0d0 0d0 0d0 0d0)))
-
-(define-g-boxed-cstruct segment nil
- (a point :inline t :initform (make-point))
- (b point :inline t :initform (make-point)))
-
-(define-g-boxed-variant-cstruct var-segment nil
- (deep :boolean :initform t)
- (a point :inline t :initform (make-point))
- (b point :inline t :initform (make-point))
- (:variant deep
- (t deep-segment
- (depth point :inline t :initform (make-point)))))
-
-(define-g-boxed-variant-cstruct event nil
- (type :int :initform 0)
- (time :int :initform 0)
- (:variant type
- (0 zero-event
- (x :int :initform 0))
- (1 one-event
- (x :double :initform 0.0d0))
- (2 three-event
- (three-type :int :initform 0)
- (:variant three-type
- (1 three-one-event
- (y :uchar :initform 0))
- (2 three-two-event
- (z :double :initform 0.0d0))
- (3 segment-event
- (segment segment :inline t :initform (make-segment)))))))
-
-(defcallback copy-event-cb (g-boxed-foreign event :return)
- ((event (g-boxed-foreign event)))
- (let ((new-event (copy-event event)))
- (incf (event-time new-event) (random 100))
- new-event))
-
-(defun call-copy-event (e)
- (foreign-funcall-pointer (callback copy-event-cb) ()
- (g-boxed-foreign event) e
- (g-boxed-foreign event :return)))
-
projects / cl-gtk2.git / commitdiff