[gtk-cffi-cvs] CVS gtk-cffi/gtk
CVS User rklochkov
rklochkov at common-lisp.net
Mon Aug 8 15:02:02 UTC 2011
Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk
In directory tiger.common-lisp.net:/tmp/cvs-serv32663/gtk
Modified Files:
cell-renderer-pixbuf.lisp gtk-cffi.asd lisp-model.lisp
package.lisp tree-model.lisp
Log Message:
Major commit. Now all exerices ex*.lisp work perfectly.
Added lisp-array model for tree-view (see ex9).
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer-pixbuf.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/cell-renderer-pixbuf.lisp 2011/08/08 15:02:02 1.2
@@ -5,7 +5,6 @@
(defcfun "gtk_cell_renderer_pixbuf_new" :pointer)
-(defmethod initialize-instance
- :after ((cell-renderer-pixbuf cell-renderer-pixbuf)
- &key &allow-other-keys)
- (setf (pointer cell-renderer-pixbuf) (gtk-cell-renderer-pixbuf-new)))
+(defmethod gconstructor ((cell-renderer-pixbuf cell-renderer-pixbuf)
+ &key &allow-other-keys)
+ (gtk-cell-renderer-pixbuf-new))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2011/08/08 15:02:02 1.2
@@ -447,6 +447,14 @@
:components
((:file :image)))
+(defsystem gtk-cffi-lisp-model
+ :description "Interface to GTK/Glib via CFFI"
+ :author "Roman Klochkov <kalimehtar at mail.ru>"
+ :version "0.1"
+ :license "GPL"
+ :depends-on (gtk-cffi-tree-model)
+ :components
+ ((:file :lisp-model)))
(defsystem gtk-cffi
:description "Interface to GTK/Glib via CFFI"
@@ -477,5 +485,6 @@
gtk-cffi-statusbar
gtk-cffi-notebook
gtk-cffi-image
- gtk-cffi-text-view))
+ gtk-cffi-text-view
+ gtk-cffi-lisp-model))
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/lisp-model.lisp 2011/08/08 15:02:02 1.2
@@ -1,57 +1,198 @@
(in-package #:gtk-cffi)
-(defclass lisp-model (g-object tree-model)
- ((g-type :type fixnum)))
+(defclass lisp-model-impl ()
+ ((columns :initarg :columns :accessor columns)))
-(defcallback cb-lisp-model-class-init :void ((class :pointer)))
+(defclass lisp-model-list (lisp-model-impl)
+ ())
-(defcallback cb-lisp-model-init :void ((self :pointer)))
+(defclass lisp-model-array (lisp-model-list)
+ ((array :initarg :array :accessor larray)))
+(defgeneric get-flags (lisp-model-impl)
+ (:method ((lisp-model-list lisp-model-list))
+ 0))
+
+(defgeneric get-n-columns (lisp-model-impl)
+ (:method ((lisp-model-list lisp-model-list))
+ 1))
+
+(defgeneric get-column-type (lisp-model-impl index)
+ (:method ((lisp-model-impl lisp-model-impl) index)
+ (name->g-type (nth index (columns lisp-model-impl)))))
+
+(defgeneric lisp-model-length (lisp-model-list)
+ (:method ((lisp-model-array lisp-model-array))
+ (length (larray lisp-model-array))))
+
+(defgeneric get-iter (lisp-model-impl iter path)
+ (:method ((lisp-model-list lisp-model-list) iter path)
+ (let ((index (get-index (make-instance 'tree-path :pointer path))))
+ (when (< index (lisp-model-length lisp-model-list))
+ (with-foreign-slots ((stamp u1) iter tree-iter-struct)
+ (setf stamp 0 u1 (make-pointer index)))))))
+
+
+(defgeneric get-path (lisp-model-impl iter)
+ (:method ((lisp-model-list lisp-model-list) iter)
+ (let ((index (pointer-address
+ (foreign-slot-value iter 'tree-iter-struct 'u1))))
+ (make-instance 'tree-path :indices (list index)))))
+
+(defgeneric get-value (lisp-model-impl iter n value)
+ (:method ((lisp-model-array lisp-model-array) iter n value)
+ (debug-out "get-value~%")
+ (let* ((index (pointer-address (foreign-slot-value
+ iter 'tree-iter-struct 'u1)))
+ (lval (nth n (aref (larray lisp-model-array) index))))
+ (g-object-cffi::init-g-value value nil lval t))))
+
+
+(defgeneric iter-next (lisp-model-impl iter)
+ (:method ((lisp-model-list lisp-model-list) iter)
+ (let ((index (pointer-address
+ (foreign-slot-value iter 'tree-iter-struct 'u1))))
+ (when (< (1+ index) (lisp-model-length lisp-model-list))
+ (setf (foreign-slot-value iter 'tree-iter-struct 'u1)
+ (make-pointer (1+ index)))))))
+
+(defgeneric iter-children (lisp-model-impl iter parent)
+ (:method ((lisp-model-list lisp-model-list) iter parent)
+ (when (null-pointer-p parent)
+ (setf (foreign-slot-value iter 'tree-iter-struct 'u1)
+ (make-pointer 0)))))
+
+
+(defgeneric iter-has-child (lisp-model-impl iter)
+ (:method ((lisp-model-list lisp-model-list) iter)
+ nil))
+
+(defgeneric iter-n-children (lisp-model-impl iter)
+ (:method ((lisp-model-list lisp-model-list) iter)
+ 0))
+
+(defgeneric iter-nth-child (lisp-model-impl iter parent n)
+ (:method ((lisp-model-list lisp-model-list) iter parent n)
+ nil))
+
+(defgeneric iter-parent (lisp-model-impl iter child)
+ (:method ((lisp-model-list lisp-model-list) iter child)
+ nil))
+
+(defgeneric ref-node (lisp-model-impl iter)
+ (:method ((lisp-model-impl lisp-model-impl) iter)
+ nil))
+
+(defgeneric unref-node (lisp-model-impl iter)
+ (:method ((lisp-model-impl lisp-model-impl) iter)
+ nil))
+(defclass lisp-model (g-object tree-model)
+ ((implementation :type standard-object
+ :initarg :implementation
+ :initform (error "Implementation not set")
+ :reader implementation)))
+
+(defcallback cb-lisp-model-class-init :void ((class :pointer))
+ (declare (ignore class))
+ (debug-out "Class init called~%"))
+
+(defcallback cb-lisp-model-init :void ((self :pointer))
+ (declare (ignore self))
+ (debug-out "Object init called~%"))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun symb (&rest args)
+ (apply #'alexandria:symbolicate args)))
+
+(defmacro init-interface (interface &rest callbacks)
+ `(progn
+ ,@(loop :for (callback args) :on callbacks :by #'cddr
+ :collecting
+ `(defcallback ,(symb '#:cb- callback) ,(car args)
+ ((object pobject) ,@(cdr args))
+ (,callback (implementation object) ,@(mapcar #'car (cdr args)))))
+ (defcallback ,(symb '#:cb-init- interface) :void ((class ,interface))
+ ,@(loop :for (callback args) :on callbacks :by #'cddr
+ :collecting `(setf (foreign-slot-value class ',interface ',callback)
+ (callback ,(symb '#:cb- callback)))))))
+
+(init-interface
+ tree-model-iface
+ get-flags (:int)
+ get-n-columns (:int)
+ get-column-type (:int (index :int))
+ get-iter (:boolean (iter tree-iter-struct) (path :pointer))
+ get-path (pobject (iter tree-iter-struct))
+ get-value (:void (iter tree-iter-struct) (n :int) (value :pointer))
+ iter-next (:boolean (iter tree-iter-struct))
+ iter-children (:boolean (iter tree-iter-struct) (parent tree-iter-struct))
+ iter-has-child (:boolean (iter tree-iter-struct))
+ iter-n-children (:int (iter tree-iter-struct))
+ iter-nth-child (:boolean (iter tree-iter-struct)
+ (parent tree-iter-struct) (n :int))
+ iter-parent (:boolean (iter tree-iter-struct) (child tree-iter-struct))
+ ref-node (:void (iter tree-iter-struct))
+ unref-node (:void (iter tree-iter-struct)))
+
+
+
+;(defcallback cb-init- :void ((class tree-model-iface) (data pdata))
+; (setf (foreign-slot-value class 'tree-model-iface 'get-flags)
+; (callback cb-get-flags)))
+ ;; (init-iface class tree-model-iface
+ ;; get-flags
+ ;; get-column-type
+ ;; get-iter
+ ;; get-path
+ ;; get-value
+ ;; iter-next
+ ;; iter-children
+ ;; iter-has-child
+ ;; iter-n-children
+ ;; iter-nth-child
+ ;; iter-parent
+ ;; ref-node
+ ;; unref-node))
+
+
+; (check-type data symbol)
+; (init-interface data
+; (g-type->lisp
+; (foreign-slot-value class 'tree-model-iface 'g-iface))
+; class))
-(defcallback cb-init-interface :void ((class :pointer) (data pdata))
- (check-type data symbol)
- (init-interface data
- (g-type->lisp
- (foreign-slot-value class 'tree-model-iface 'g-iface))
- class))
-(defcallback cb-get-flags :int ((object :pointer))
- 0)
-(defcallback cb-get-column-type :int ((object pobject) (index :int))
- (get-column-type object index))
(defcstruct g-interface-info
(init :pointer)
(finalize :pointer)
(data pdata))
-(defcstruct lisp-model
- (parent-instance g-object))
-
-(defcstruct lisp-model-class
- (parent-class g-object-class))
+(defcfun gtk-tree-model-get-type :uint)
-(let ((interface-info (foreign-alloc 'g-interface-info)))
+(let ((interface-info (foreign-alloc 'g-interface-info))
+ g-type)
(setf (foreign-slot-value interface-info 'g-interface-info 'init)
- (callback cb-init-interface))
+ (callback cb-init-tree-model-iface))
(defmethod get-type ((lisp-model lisp-model))
- (or (g-type lisp-model)
+ (or g-type
(prog1
- (setf (g-type lisp-model)
+ (setf g-type
(g-type-register-static-simple
- (name->g-type :object)
+ #.(name->g-type :object)
(g-intern-static-string "GtkLispModel")
- (foreign-type-size 'lisp-model-class)
- cb-lisp-model-class-init
- (foreign-type-size 'lisp-model)
- cb-lisp-model-init
+ (foreign-type-size 'g-object-class)
+ (callback cb-lisp-model-class-init)
+ (foreign-type-size 'g-object)
+ (callback cb-lisp-model-init)
0))
- (g-type-add-interface-static (g-type lisp-model)
+ (g-type-add-interface-static g-type
(gtk-tree-model-get-type)
interface-info)))))
-(defmethod gconstructor ((lisp-model lisp-model))
- (g-object-new (get-type lisp-model))
\ No newline at end of file
+(defmethod gconstructor ((lisp-model lisp-model) &rest initargs)
+ (declare (ignore initargs))
+ (new (get-type lisp-model)))
\ No newline at end of file
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2011/08/08 15:02:02 1.2
@@ -283,6 +283,10 @@
#:icon-source
#:image
+
+ #:lisp-model
+ #:lisp-model-array
+ #:larray
))
(in-package #:gtk-cffi)
--- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/04/25 19:16:08 1.1.1.1
+++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2011/08/08 15:02:02 1.2
@@ -101,11 +101,13 @@
(g-iface g-type-interface)
(row-changed :pointer)
(row-inserted :pointer)
+ (has-child-toggled :pointer)
(row-deleted :pointer)
(row-reordered :pointer)
; virtual methods
(get-flags :pointer)
+ (get-n-columns :pointer)
(get-column-type :pointer)
(get-iter :pointer)
(get-path :pointer)
More information about the gtk-cffi-cvs
mailing list