From rklochkov at common-lisp.net Sat Dec 15 14:33:07 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 15 Dec 2012 06:33:07 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi In directory tiger.common-lisp.net:/tmp/cvs-serv20011 Added Files: LICENSE Log Message: Fixed LICENSE --- /project/gtk-cffi/cvsroot/gtk-cffi/LICENSE 2012/12/15 14:33:07 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/LICENSE 2012/12/15 14:33:07 1.1 BSD for glib/g-object/gdk LLGPL for gtk/gtk-ext From rklochkov at common-lisp.net Sat Dec 15 14:33:09 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 15 Dec 2012 06:33:09 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv20011/examples Modified Files: ex4.lisp Log Message: Fixed LICENSE --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/10/07 12:02:11 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/12/15 14:33:08 1.5 @@ -91,7 +91,7 @@ (add scrolled-win *view*)) (let ((field-header '("Row #" "Description" "Qty" "Price")) - (field-justification '(0.0 0.0 .5 1.0))) + (field-justification '(0 0 .5 1))) (loop :for col :from 0 :below (length field-header) :do (let ((cell-renderer (make-instance 'cell-renderer-text))) (setf (property cell-renderer :xalign) From rklochkov at common-lisp.net Sat Dec 15 14:33:12 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 15 Dec 2012 06:33:12 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv20011/gtk Modified Files: tree-model.lisp tree-selection.lisp tree-view.lisp Log Message: Fixed LICENSE --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/10/07 12:02:11 1.16 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/12/15 14:33:10 1.17 @@ -45,16 +45,20 @@ (defmethod translate-to-foreign ((value string) (tree-path tree-path)) (gtk-tree-path-new-from-string value)) +(defmethod translate-to-foreign ((value null) (tree-path tree-path)) + (null-pointer)) + + (defmethod free-ptr ((tree-path (eql 'tree-path)) ptr) (gtk-tree-path-free ptr)) -(define-foreign-type cb-tree-path (tree-path) +(define-foreign-type ptree-path (tree-path) ((free-from-foreign :initform nil)) (:documentation "Tree path for callbacks") - (:simple-parser cb-tree-path) + (:simple-parser ptree-path) (:actual-type :pointer)) -(defmethod free-ptr ((tree-path (eql 'cb-tree-path)) ptr) +(defmethod free-ptr ((tree-path (eql 'ptree-path)) ptr) (gtk-tree-path-free ptr)) (defclass tree-row-reference (object) @@ -126,7 +130,7 @@ (make-foreach tree-model (model pobject) - (path cb-tree-path) + (path ptree-path) (tree-iter (object tree-iter)) (data pdata)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/10/07 12:02:11 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/12/15 14:33:10 1.5 @@ -26,7 +26,7 @@ (defcallback cb-tree-selection-func :boolean - ((selection pobject) (model pobject) (path cb-tree-path) + ((selection pobject) (model pobject) (path ptree-path) (path-currently-selected :boolean) (data pdata)) (funcall data selection model path path-currently-selected)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/10/07 12:02:11 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/12/15 14:33:11 1.5 @@ -27,7 +27,9 @@ hover-selection :boolean hover-expand :boolean rubber-banding :boolean - search-column :int) + search-column :int + expander-column pobject) + (deffuns tree-view (remove-column :int (column pobject)) @@ -35,8 +37,18 @@ (insert-column :int (column pobject) (position :int) &key) (:get selection pobject) (:get columns g-list-object) - (:get column pobject (n :int))) - + (:get column pobject (n :int)) + (:get n-columns :int) + (move-column-after :void (column pobject) (base-column pobject)) + (scroll-to-point :void (x :int) (y :int))) + +(defcfun gtk-tree-view-scroll-to-cell :void + (tree-view pobject) (path ptree-path) (column pobject) (use-align :boolean) (row-align :float) (col-align :float)) + +(defgeneric scroll-to-cell (tree-view path column &key row-align col-align) + (:method ((tree-view tree-view) path column &key (row-align 0.0 row-align-p) (col-align 0.0 col-align-p)) + (gtk-tree-view-scroll-to-cell tree-view path column (or row-align-p col-align-p) row-align col-align))) + (defmethod (setf columns) (columns (tree-view tree-view)) (dolist (column (columns tree-view)) @@ -75,7 +87,7 @@ (gtk-tree-view-get-cursor tree-view path column))) (defcfun gtk-tree-view-insert-column-with-data-func :int - (tree-view pobject) (postion :int) (title :string) (cell pobject) + (tree-view pobject) (position :int) (title :string) (cell pobject) (data-func pfunction) (data pdata) (destroy pfunction)) (defmethod insert-column ((tree-view tree-view) (cell cell-renderer) position @@ -83,6 +95,19 @@ (set-callback tree-view gtk-tree-view-insert-column-with-data-func cb-cell-data-func func data destroy-notify position title cell)) + +(defcfun gtk-tree-view-set-column-drag-function :void + (tree-view pobject) (func pfunction) (user-data pdata) (destroy pfunction)) + +(defcallback cb-column-drop-function :boolean + ((tree-view pobject) (column pobject) (prev-column pobject) (next-column pobject) (data pdata)) + (funcall data tree-view column prev-column next-column)) + +(defgeneric (setf column-drag-function) (func tree-view &key data destroy-notify) + (:documentation "gtk_tree_view_set_column_drag_function") + (:method (func (tree-view tree-view) &key data destroy-notify) + (set-callback tree-view gtk-tree-view-set-column-drag-function + cb-column-drop-function func data destroy-notify))) (init-slots tree-view (on-select) From rklochkov at common-lisp.net Sat Dec 15 14:33:15 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Sat, 15 Dec 2012 06:33:15 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/utils Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/utils In directory tiger.common-lisp.net:/tmp/cvs-serv20011/utils Modified Files: gtk-cffi-utils.asd Log Message: Fixed LICENSE --- /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2011/08/26 17:16:14 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/utils/gtk-cffi-utils.asd 2012/12/15 14:33:14 1.3 @@ -7,8 +7,8 @@ :description "Different utils for gtk-cffi" :author "Roman Klochkov " :version "1.0" - :license "LGPL" + :license "BSD" :depends-on (alexandria iterate cffi) :components ((:file package) - (:file utils :depends-on (package)))) \ No newline at end of file + (:file utils :depends-on (package)))) From rklochkov at common-lisp.net Mon Dec 24 16:32:05 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 24 Dec 2012 08:32:05 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv3527/g-object Modified Files: defslots.lisp g-object.lisp Log Message: Reloading after CVS was broken --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/10/07 12:02:11 1.15 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp 2012/12/24 16:32:05 1.16 @@ -147,18 +147,21 @@ (defgeneric foreach (class func &optional data) (:documentation "For each element in CLASS execute FUNC")) (defmacro make-foreach (class &rest params) - (let ((gtk-name (symbolicate 'gtk- class '-foreach)) - (cb-name (gensym))) - `(progn - (defcfun ,gtk-name :void - (,class pobject) (func pfunction) (data (pdata :free-to-foreign t))) - (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata)) - (funcall *callback* ,@(mapcar #'car params))) - (defmethod foreach ((,class ,class) func &optional data) - (if (functionp func) - (let ((*callback* func)) - (,gtk-name ,class (callback ,cb-name) data)) - (,gtk-name ,class func data)))))) + "Class is a symbol: class or list: (class gtk-name)" + (destructuring-bind (class gtk-name) + (if (listp class) class + (list class (symbolicate 'gtk- class '-foreach))) + (let ((cb-name (gensym))) + `(progn + (defcfun ,gtk-name :void + (,class pobject) (func pfunction) (data (pdata :free-to-foreign t))) + (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata)) + (funcall *callback* ,@(mapcar #'car params))) + (defmethod foreach ((,class ,class) func &optional data) + (if (functionp func) + (let ((*callback* func)) + (,gtk-name ,class (callback ,cb-name) data)) + (,gtk-name ,class func data))))))) (defmacro set-callback (object setter cb-standard func data destroy-notify &rest add-params) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/08/18 13:55:27 1.14 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/12/24 16:32:05 1.15 @@ -62,17 +62,18 @@ ,@(when set `((defcfun ,set :void (object pobject) (name cffi-keyword) (value pobject)) - (defgeneric (setf ,name) (values ,object &rest keys)) - (defmethod (setf ,name) (values (,object ,object) &rest keys) - "Usage: + (defgeneric (setf ,name) (values ,object &rest keys) + (:method (values (,object ,object) &rest keys) + "Usage: (setf (property object :property) value) (setf (property object :prop1 :prop2) (list value1 value2))" - (mapc (lambda (key value) - (declare (type (or symbol string) key)) - (let ((skey (string-downcase key))) - (with-g-value (:value value :g-type (,type ,object skey)) - (,set ,object skey *g-value*)))) - keys (if (listp values) values (list values)))))) + (mapc (lambda (key value) + (declare (type (or symbol string) key)) + (let ((skey (string-downcase key))) + (with-g-value (:value value + :g-type (,type ,object skey)) + (,set ,object skey *g-value*)))) + keys (if (listp values) values (list values))))))) (defcfun ,get :void (object pobject) (name cffi-keyword) (value pobject)) From rklochkov at common-lisp.net Mon Dec 24 16:32:05 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 24 Dec 2012 08:32:05 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv3527/gtk Modified Files: combo-box.lisp container.lisp generics.lisp gtk-cffi.asd package.lisp selections.lisp tree-selection.lisp tree-view.lisp widget.lisp Added Files: drag-drop.lisp Log Message: Reloading after CVS was broken --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/10/07 12:02:11 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/combo-box.lisp 2012/12/24 16:32:05 1.7 @@ -12,6 +12,7 @@ (defmethod gconstructor ((combo-box combo-box) &key model area entry &allow-other-keys) + (initialize combo-box '(model area entry)) (cond (model (if entry @@ -26,13 +27,6 @@ (gtk-combo-box-new-with-entry) (gtk-combo-box-new))))) - -;; separate declaration to avoid auto-adding to initargs -(defcfun gtk-combo-box-set-model :void (combo-box pobject) (model pobject)) -(defgeneric (setf model) (tree-model combo-box) - (:method (tree-model (combo-box combo-box)) - (gtk-combo-box-set-model combo-box tree-model) tree-model)) - (defslots combo-box wrap-width :int row-span-column :int @@ -44,10 +38,10 @@ focus-on-click :boolean button-sensitivity sensitivity-type entry-text-column :int + model pobject popup-fixed-width :boolean) (deffuns combo-box - (:get model pobject) (:get active-id :string) (popup-for-device :void (device pobject)) (popup :void) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/10/07 12:02:11 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/container.lisp 2012/12/24 16:32:05 1.7 @@ -31,11 +31,14 @@ `(pack ,box ,@(ensure-cons widget))) widgets))) -(defmethod (setf kids) (kids (container container)) - (mapc (lambda (x) (setf (kid container) x)) kids)) +(defgeneric (setf kids) (kids container) + (:documentation "Pack kids to container") + (:method (kids (container container)) + (mapc (lambda (x) (setf (kid container) x)) kids))) -(defmethod (setf kid) (kid (container container)) - (pack container kid)) +(defgeneric (setf kid) (kid container) + (:method (kid (container container)) + (pack container kid))) (defmethod initialize-instance :after ((container container) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2012/10/07 12:02:11 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/generics.lisp 2012/12/24 16:32:05 1.6 @@ -4,5 +4,8 @@ (defgeneric text (widget &key)) ;; entry, label, text-buffer (defgeneric (setf text) (value widget &key)) (defgeneric layout-offsets (object)) ;; entry, label, scale +(defgeneric (setf model) (model object)) ;; combo-box, list-store, + ;; tree-model-filter + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/10/07 12:02:11 1.29 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/gtk-cffi.asd 2012/12/24 16:32:05 1.30 @@ -45,7 +45,10 @@ (:file invisible :depends-on (widget)) (:file actionable :depends-on (widget)) (:file activatable :depends-on (widget)) - (:file switch :depends-on (actionable activatable)))) + (:file switch :depends-on (actionable activatable)) + (:file drag-drop :depends-on (widget)) + (:file selections :depends-on (drag-drop)))) + (defsystem gtk-cffi-misc :description "Interface to GTK/Glib via CFFI" --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/10/07 12:02:11 1.30 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/package.lisp 2012/12/24 16:32:05 1.31 @@ -600,6 +600,7 @@ ;; tree-view slots #:model #:search-column + #:expander-column #:level-indentation #:selection #:hover-expand @@ -612,13 +613,10 @@ ;; tree-view methods #:append-column #:insert-column - #:get-selection + #:selection #:path-at-pos - #:with-path-at-pos - #:%path #:column - #:get-cursor - #:with-get-cursor-path + #:cursor #:remove-column #:tree-view-column --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/01/28 13:44:45 1.1 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/12/24 16:32:05 1.2 @@ -3,4 +3,7 @@ (defclass target-list (object) ()) - +(defcstruct* target-entry + (target :string) + (flags :uint) + (info :uint)) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/12/15 14:33:10 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-selection.lisp 2012/12/24 16:32:05 1.6 @@ -60,25 +60,29 @@ (mem-ref p 'pobject))))) -(defcfun gtk-tree-selection-selected-foreach :void - (selection pobject) (func pfunction) (data pdata)) - -(defvar *tree-selection-foreach* nil) - -(defcallback cb-tree-selection-foreach :boolean - ((model pobject) (path tree-path :free-from-foreign nil) - (tree-iter (struct tree-iter)) (data pdata)) - (when *tree-selection-foreach* - (funcall *tree-selection-foreach* model path tree-iter data))) - -(defmethod foreach ((tree-selection tree-selection) - func &optional (data (null-pointer))) - (when func - (let ((*tree-selection-foreach* func)) - (gtk-tree-selection-selected-foreach - tree-selection (if (functionp func) - (callback cb-tree-selection-foreach) func) - data)))) +(make-foreach (tree-selection gtk-tree-selection-selected-foreach) + (model pobject) (path tree-path :free-from-foreign nil) + (tree-iter (struct tree-iter)) (data pdata)) + +;; (defcfun gtk-tree-selection-selected-foreach :void +;; (selection pobject) (func pfunction) (data pdata)) + +;; (defvar *tree-selection-foreach* nil) + +;; (defcallback cb-tree-selection-foreach :boolean +;; ((model pobject) (path tree-path :free-from-foreign nil) +;; (tree-iter (struct tree-iter)) (data pdata)) +;; (when *tree-selection-foreach* +;; (funcall *tree-selection-foreach* model path tree-iter data))) + +;; (defmethod foreach ((tree-selection tree-selection) +;; func &optional (data (null-pointer))) +;; (when func +;; (let ((*tree-selection-foreach* func)) +;; (gtk-tree-selection-selected-foreach +;; tree-selection (if (functionp func) +;; (callback cb-tree-selection-foreach) func) +;; data)))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/12/15 14:33:11 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/12/24 16:32:05 1.6 @@ -1,3 +1,11 @@ +;;; GtkTreeView +;;; +;;; (foreach tree-view ...) = gtk-tree-view-map-expanded-rows +;;; (path-at-pos ... :is-blank t) = gtk-tree-view-is-blank-at-pos +;;; (convert-bin-window-to-widget tree-view x y) -> (list wx wy) = +;;; gtk-tree-view-convert-bin-window-to-widget-coords +;;; (convert-{smth} ...) = gtk-tree-view-convert-{smth}-coords + (in-package :gtk-cffi) (defclass tree-view (container) @@ -28,7 +36,8 @@ hover-expand :boolean rubber-banding :boolean search-column :int - expander-column pobject) + expander-column pobject + reorderable :boolean) (deffuns tree-view @@ -40,14 +49,29 @@ (:get column pobject (n :int)) (:get n-columns :int) (move-column-after :void (column pobject) (base-column pobject)) - (scroll-to-point :void (x :int) (y :int))) + (scroll-to-point :void (x :int) (y :int)) + (row-activated :void (path tree-path) (comumn pobject)) + (expand-all :void) + (collapse-all :void) + (expand-to-path :void (path tree-path)) + (expand-row :void (path tree-path) (open-all :boolean)) + (collapse-row :void (path tree-path)) + (row-expanded :boolean (path tree-path)) + (:get bin-window pobject)) + + + (defcfun gtk-tree-view-scroll-to-cell :void - (tree-view pobject) (path ptree-path) (column pobject) (use-align :boolean) (row-align :float) (col-align :float)) + (tree-view pobject) (path ptree-path) (column pobject) (use-align :boolean) + (row-align :float) (col-align :float)) (defgeneric scroll-to-cell (tree-view path column &key row-align col-align) - (:method ((tree-view tree-view) path column &key (row-align 0.0 row-align-p) (col-align 0.0 col-align-p)) - (gtk-tree-view-scroll-to-cell tree-view path column (or row-align-p col-align-p) row-align col-align))) + (:method ((tree-view tree-view) path column + &key (row-align 0.0 row-align-p) (col-align 0.0 col-align-p)) + (gtk-tree-view-scroll-to-cell tree-view path column + (or row-align-p col-align-p) + row-align col-align))) (defmethod (setf columns) (columns (tree-view tree-view)) @@ -73,18 +97,38 @@ (x :int) (y :int) (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) -(defmethod path-at-pos ((tree-view tree-view) x y) - (with-foreign-outs-list - ((path 'tree-path) (column 'pobject) - (cell-x :int) (cell-y :int)) :if-success - (gtk-tree-view-get-path-at-pos tree-view x y path column cell-x cell-y))) +(defgeneric path-at-pos (tree-view x y) + (:method ((tree-view tree-view) x y) + (with-foreign-outs-list + ((path 'tree-path) (column 'pobject) + (cell-x :int) (cell-y :int)) :if-success + (gtk-tree-view-get-path-at-pos tree-view x y path column cell-x cell-y)))) (defcfun gtk-tree-view-get-cursor :void (view pobject) (path :pointer) (column :pointer)) -(defmethod get-cursor ((tree-view tree-view)) - (with-foreign-outs-list ((path 'tree-path) (column 'pobject)) :ignore - (gtk-tree-view-get-cursor tree-view path column))) +(defgeneric cursor (tree-view) + (:method ((tree-view tree-view)) + (with-foreign-outs-list ((path 'tree-path) (column 'pobject)) :ignore + (gtk-tree-view-get-cursor tree-view path column)))) + +(defcfun gtk-tree-view-set-cursor :void + (tree-view pobject) (path tree-path) (focus-column pobject) + (start-editing :boolean)) + +(defcfun gtk-tree-view-set-cursor-on-cell :void + (tree-view pobject) (path tree-path) (focus-column pobject) + (focus-cell pobject) (start-editing :boolean)) + +(defgeneric (setf cursor) (path+column tree-view &key start-editing cell) + (:method (path+column (tree-view tree-view) &key start-editing cell) + (destructuring-bind (path column) path+column + (if cell + (gtk-tree-view-set-cursor-on-cell tree-view path column + cell start-editing) + (gtk-tree-view-set-cursor tree-view path column start-editing))) + path+column)) + (defcfun gtk-tree-view-insert-column-with-data-func :int (tree-view pobject) (position :int) (title :string) (cell pobject) @@ -100,15 +144,99 @@ (tree-view pobject) (func pfunction) (user-data pdata) (destroy pfunction)) (defcallback cb-column-drop-function :boolean - ((tree-view pobject) (column pobject) (prev-column pobject) (next-column pobject) (data pdata)) + ((tree-view pobject) (column pobject) (prev-column pobject) + (next-column pobject) (data pdata)) (funcall data tree-view column prev-column next-column)) -(defgeneric (setf column-drag-function) (func tree-view &key data destroy-notify) +(defgeneric (setf column-drag-function) (func tree-view + &key data destroy-notify) (:documentation "gtk_tree_view_set_column_drag_function") (:method (func (tree-view tree-view) &key data destroy-notify) (set-callback tree-view gtk-tree-view-set-column-drag-function cb-column-drop-function func data destroy-notify))) - + +(make-foreach (tree-view gtk-tree-view-map-expanded-rows) + (path ptree-path) (data pdata)) + +(defcfun gtk-tree-view-is-blank-at-pos :boolean + (tree-view pobject) (x :int) (y :int) + (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) + +(defcfun gtk-tree-view-path-at-pos :boolean + (tree-view pobject) (x :int) (y :int) + (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) + +(defgeneric path-at-pos (tree-view x y &key is-blank) + (:documentation "if is-blank gtk-tree-view-is-blank-at-pos called, else +gtk-tree-view-path-at-pos") + (:method ((tree-view tree-view) x y &key is-blank) + (with-foreign-outs ((path 'tree-path) (column 'pobject) + (cell-x :int) (cell-y :int)) :return + (funcall (if is-blank #'gtk-tree-view-is-blank-at-pos + #'gtk-tree-view-get-path-at-pos) + tree-view x y path column cell-x cell-y)))) + +(macrolet ((get-area (area-type) + (let ((cname (symbolicate 'gtk-tree-view-get- area-type '-area)) + (lname (symbolicate area-type '-area))) + `(progn + (defcfun ,cname :void + (tree-view pobject) (path tree-path) (column pobject) + (rect (struct rectangle :out t))) + (defgeneric ,lname + (tree-view path column) + (:method ((tree-view tree-view) path column) + (let ((res (make-instance 'rectangle))) + (,cname tree-view path column res) + res))))))) + (get-area background) + (get-area cell)) + +(defcfun gtk-tree-view-get-visible-rect :void + (tree-view pobject) (visible-rect (struct rectangle :out t))) + +(defgeneric visible-rect (tree-view) + (:method ((tree-view tree-view)) + (let ((res (make-instance 'rectangle))) + (gtk-tree-view-get-visible-rect tree-view res) + res))) + +(defcfun gtk-tree-view-get-visible-range :void + (tree-view pobject) (start-path :pointer) (end-path :pointer)) + +(defgeneric visible-range (tree-view) + (:method ((tree-view tree-view)) + (with-foreign-outs-list ((start-path 'tree-path) (end-path 'tree-path)) + :ignore + (gtk-tree-view-get-visible-range tree-view start-path end-path)))) + +(macrolet ((def-coords (from to) + (flet ((name-coord (sym1 sym2) + (symbolicate (aref (symbol-name sym1) 0) sym2))) + (let ((cfun (symbolicate 'gtk-tree-view-convert- from + '-to- to '-coords)) + (lfun (symbolicate 'convert- from '-to- to)) + (from-x (name-coord from 'x)) + (from-y (name-coord from 'y)) + (to-x (name-coord to 'x)) + (to-y (name-coord to 'y))) + `(progn + (defcfun ,cfun :void + (tree-view pobject) + (,from-x :int) (,from-y :int) + (,to-x :pointer) (,to-y :pointer)) + (defgeneric ,lfun (tree-view x y) + (:method ((tree-view tree-view) x y) + (with-foreign-outs-list ((,to-x :int) (,to-y :int)) + :ignore + (,cfun tree-view x y ,to-x ,to-y))))))))) + (def-coords bin-window tree) + (def-coords bin-window widget) + (def-coords tree bin-window) + (def-coords tree widget) + (def-coords widget bin-window) + (def-coords widget tree)) + (init-slots tree-view (on-select) (when on-select --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/10/07 12:02:11 1.17 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/12/24 16:32:05 1.18 @@ -169,9 +169,9 @@ (accel-mods modifier-type)) (list-accel-closures g-list) (can-activate-accel :boolean (signal-id :uint)) - ((widget-event . event) :boolean (event event)) - (send-expose :int (event event)) - (send-focus-change :boolean (event event)) + ((widget-event . event) :boolean (event (:pointer (:union event)))) + (send-expose :int (event (:pointer (:union event)))) + (send-focus-change :boolean (event (:pointer (:union event)))) (reparent :void (new-parent pobject)) (is-focus :boolean) (grab-focus :void) @@ -245,10 +245,11 @@ (defcfun gtk-widget-get-allocation :void (widget pobject) (allocation (struct allocation :out t))) -(defmethod allocation ((widget widget)) - (let ((res (make-instance 'allocation))) - (gtk-widget-get-allocation widget res) - res)) +(defgeneric allocation (widget) + (:method ((widget widget)) + (let ((res (make-instance 'allocation))) + (gtk-widget-get-allocation widget res) + res))) (setf (documentation 'clipboard 'function) "SELECTION should be :PRIMARY or :CLIPOARD") @@ -279,11 +280,10 @@ (context :pointer) (gdk-window pobject)) (defgeneric cairo-should-draw-window (window &optional context) - (:documentation "WINDOW may be GdkWindow or GtkWidget")) -(defmethod cairo-should-draw-window (window - &optional (context cl-cairo2:*context*)) - (cl-cairo2::with-context-pointer (context cntx-pointer) - (gtk-cairo-should-draw-window cntx-pointer window))) + (:documentation "WINDOW may be GdkWindow or GtkWidget") + (:method (window &optional (context cl-cairo2:*context*)) + (cl-cairo2::with-context-pointer (context cntx-pointer) + (gtk-cairo-should-draw-window cntx-pointer window)))) (defmethod cairo-should-draw-window ((widget widget) &optional (context cl-cairo2:*context*)) @@ -306,42 +306,42 @@ (defcfun gtk-widget-unset-state-flags :void (widget pobject) (flags state-flags)) -(defgeneric (setf state-flags) (value widget &key type)) -(defmethod (setf state-flags) (value (widget widget) &key type) - "If TYPE = :SET, only set bits, :UNSET -- unset bits, +(defgeneric (setf state-flags) (value widget &key type) + (:method (value (widget widget) &key type) + "If TYPE = :SET, only set bits, :UNSET -- unset bits, otherwise set state = VALUE" - (case type - (:set (gtk-widget-set-state-flags widget value nil)) - (:unset (gtk-widget-unset-state-flags widget value)) - (t (gtk-widget-set-state-flags widget value t)))) + (case type + (:set (gtk-widget-set-state-flags widget value nil)) + (:unset (gtk-widget-unset-state-flags widget value)) + (t (gtk-widget-set-state-flags widget value t))))) (defcfun gtk-widget-get-preferred-height :void (widget pobject) (minimum :pointer) (natural :pointer)) (defcfun gtk-widget-get-preferred-height-for-width :void (widget pobject) (width :int) (minimum :pointer) (natural :pointer)) -(defgeneric preferred-height (widget &key for-width)) -(defmethod preferred-height ((widget widget) &key for-width) - "Returns (values minimum natural)" - (with-foreign-outs ((minimum :int) (natural :int)) :ignore - (if for-width - (gtk-widget-get-preferred-height-for-width widget - for-width minimum natural) - (gtk-widget-get-preferred-height widget minimum natural)))) +(defgeneric preferred-height (widget &key for-width) + (:method ((widget widget) &key for-width) + "Returns (values minimum natural)" + (with-foreign-outs ((minimum :int) (natural :int)) :ignore + (if for-width + (gtk-widget-get-preferred-height-for-width widget + for-width minimum natural) + (gtk-widget-get-preferred-height widget minimum natural))))) (defcfun gtk-widget-get-preferred-width :void (widget pobject) (minimum :pointer) (natural :pointer)) (defcfun gtk-widget-get-preferred-width-for-height :void (widget pobject) (height :int) (minimum :pointer) (natural :pointer)) -(defgeneric preferred-width (widget &key for-height)) -(defmethod preferred-width ((widget widget) &key for-height) - "Returns (values minimum natural)" - (with-foreign-outs ((minimum :int) (natural :int)) :ignore - (if for-height - (gtk-widget-get-preferred-width-for-height widget - for-height minimum natural) - (gtk-widget-get-preferred-width widget minimum natural)))) +(defgeneric preferred-width (widget &key for-height) + (:method ((widget widget) &key for-height) + "Returns (values minimum natural)" + (with-foreign-outs ((minimum :int) (natural :int)) :ignore + (if for-height + (gtk-widget-get-preferred-width-for-height widget + for-height minimum natural) + (gtk-widget-get-preferred-width widget minimum natural))))) (defcenum size-request-mode :height-for-width :width-for-height) @@ -349,40 +349,43 @@ (defgtkgetter request-mode size-request-mode widget) (defcfun gtk-widget-get-preferred-size :void - (widget pobject) (minimum :pointer) (natural :pointer)) + (widget pobject) + (minimum (struct requisition :out t)) + (natural (struct requisition :out t))) (defgeneric preferred-size (widget) (:method ((widget widget)) "Returns (values minimum natural). Minimum and natural are requisition objects." - (with-foreign-outs ((minimum 'requisition) (natural 'requisition)) - :ignore - (gtk-widget-get-preferred-size widget minimum natural)))) + (let ((minimum (make-instance 'requisition)) + (natural (make-instance 'requisition))) + (gtk-widget-get-preferred-size widget minimum natural) + (values minimum natural)))) -(defcstruct requested-size +(defcstruct* requested-size "GtkRequestedSize" (data pobject) (minimum-size :int) (natural-size :int)) (defcfun gtk-distribute-natural-allocation :int - (extra-space :int) (n-requested-sizes :int) (sizes :pointer)) + (extra-space :int) (n-requested-sizes :int) + (sizes (carray (struct requested-size)))) (defun distribute-natural-allocation (extra-space sizes) "EXTRA-SPACE -- integer, extra space to redistribute among children. SIZES -- {(widget minimum-size natural-size)}*" - (let ((length (length sizes))) - (let ((sizes-struct (foreign-alloc 'requested-size :count length))) - (iter - (for i from 0 below length) - (for x in sizes) - (let ((el (mem-aref sizes-struct 'requested-size i))) - (with-foreign-slots ((data minimum-size natural-size) - el requested-size) - (setf data (first x) - minimum-size (second x) - natural-size (third x))))) - (gtk-distribute-natural-allocation extra-space length sizes-struct)))) + (let ((sizes-struct + (mapcar (lambda (size) + (destructuring-bind (widget minimum-size natural-size) size + (let ((res (make-instance 'requested-size))) + (setf (data res) widget + (minimum-size res) minimum-size + (natural-size res) natural-size) + res))) + sizes))) + (gtk-distribute-natural-allocation extra-space (length sizes) + sizes-struct))) (template (name with-type) ((color t) (font nil) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/drag-drop.lisp 2012/12/24 16:32:06 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/drag-drop.lisp 2012/12/24 16:32:06 1.1 (in-package :gtk-cffi) (defbitfield dest-defaults :motion :highlight :drop (:all #x7)) (defcfun gtk-drag-dest-set :void (widget pobject) (targets (carray (struct target-entry))) (n-targets :int) (action drag-action)) (defun drag-dest-set (widget targets action) (gtk-drag-dest-set widget targets (length targets) action)) From rklochkov at common-lisp.net Mon Dec 24 16:42:08 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 24 Dec 2012 08:42:08 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi In directory tiger.common-lisp.net:/tmp/cvs-serv4753 Added Files: README.md Log Message: Fis cvs --- /project/gtk-cffi/cvsroot/gtk-cffi/README.md 2012/12/24 16:42:08 NONE +++ /project/gtk-cffi/cvsroot/gtk-cffi/README.md 2012/12/24 16:42:08 1.1 gtk-cffi ======== GTK-CFFI is a library, providing CFFI layer to GTK3. License is LLGPL for GTK, BSD for GLib and GDK. GTK interface is mapped like this:
GTKLisp
gtk_widget_set_parent(setf (parent widget) new-parent)
gtk_widget_get_parent(parent widget)
Properties realized as (property object :property-name). There are corresponding setters for them. Signals: (gsignal object :signal-name). Value of signal can be name of C function, its address, corresponding keyword or lisp function, including closure. Along with GtkListStore, I made LispStore. It can be filled much faster, than ListStore. Why not cl-gtk2 =============== - cl-gtk2 supports only GTK2, gtk-cffi supports GTK3 - cl-gtk2 describes properties by hand, gtk-cffi uses g-object-class-find-property and caching results - cl-gtk2 offers c-style functions like (gtk:widget-queue-resize-no-redraw widget), in gtk-cffi this will be (gtk:queue-resize widget :no-redraw t) From rklochkov at common-lisp.net Mon Dec 31 13:33:38 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:33:38 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/examples Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/examples In directory tiger.common-lisp.net:/tmp/cvs-serv30885/examples Modified Files: ex4.lisp Log Message: Backed to CFFI 10.7 (was version from git) --- /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/12/15 14:33:08 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/examples/ex4.lisp 2012/12/31 13:33:38 1.6 @@ -168,7 +168,7 @@ ;;(declare (optimize speed)) ;;(format t ;; "~A ~A ~A ~A ~A~%" column cell model iter col-num) - (let* ((iter (make-instance 'tree-iter :pointer iter-ptr)) + (let* ((iter (make-instance 'tree-iter :pointer iter-ptr :free-after nil)) ;; (row-num (cffi:mem-aref ;; (gtk-cffi::gtk-tree-path-get-indices ;; (gtk-cffi::gtk-tree-model-get-path From rklochkov at common-lisp.net Mon Dec 31 13:33:38 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:33:38 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-lib Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-lib In directory tiger.common-lisp.net:/tmp/cvs-serv30885/g-lib Modified Files: error.lisp variant.lisp Log Message: Backed to CFFI 10.7 (was version from git) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/10/07 12:02:11 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/error.lisp 2012/12/31 13:33:38 1.8 @@ -20,18 +20,20 @@ (defmethod free :before ((g-error g-error)) (g-clear-error g-error)) -(defcstruct g-error +(defcstruct* g-error-struct "GError struct" (domain g-quark) (errno :int) (message :string)) (defun get-error (g-error) - (let ((p (mem-ref (pointer g-error) :pointer))) - (unless (null-pointer-p p) - (with-foreign-slots - ((domain errno message) p (:struct g-error)) - `(:domain ,domain :errno ,errno :message ,message))))) + (let ((p (make-instance 'g-error-struct + :pointer (mem-ref (pointer g-error) :pointer) + :free-after nil))) + (when p + (list :domain (domain p) + :errno (errno p) + :message (message p))))) ;(defmethod print-object ((g-error g-error) stream) ; (let ((err (get-error g-error))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/variant.lisp 2012/08/24 19:27:54 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/variant.lisp 2012/12/31 13:33:38 1.6 @@ -37,7 +37,7 @@ (defcfun g-variant-parse :pointer (type variant-type) (text :pointer) (limit :pointer) (end :pointer) - (g-error (:pointer (:struct g-error)))) + (g-error object)) (defcfun g-variant-print (:string :free-from-foreign t) (variant :pointer) (annotate :boolean)) From rklochkov at common-lisp.net Mon Dec 31 13:33:38 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:33:38 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/g-object Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object In directory tiger.common-lisp.net:/tmp/cvs-serv30885/g-object Modified Files: g-object-class.lisp g-object.lisp g-type.lisp g-value.lisp package.lisp subclass.lisp Log Message: Backed to CFFI 10.7 (was version from git) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2012/08/18 13:55:27 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp 2012/12/31 13:33:38 1.8 @@ -10,8 +10,8 @@ (defclass g-object-class (object) ((free-after :initform nil))) -(defcstruct g-object-class - (type-class (:struct g-type-class)) +(defcstruct* g-object-class-struct + (type-class g-type-class) ; :struct (construct-properties :pointer) (constructor :pointer) (set-property :pointer) @@ -62,20 +62,23 @@ :readable :writable :construct :construct-only :lax-validation :static-name :static-nick :static-blurb) -(defcstruct g-param-spec +(defcstruct* g-param-spec-struct "GParamSpec" (g-type-instance :pointer) (name :string) (flags g-param-flags) - (type :ulong) + (g-param-spec-type :ulong) (owner-type :ulong)) (defmethod flags ((g-param-spec g-param-spec)) - (foreign-slot-value (pointer g-param-spec) '(:struct g-param-spec) 'flags)) + (flags (make-instance 'g-param-spec-struct :pointer (pointer g-param-spec)))) (defmethod g-type ((g-param-spec g-param-spec) &key owner) - (foreign-slot-value (pointer g-param-spec) - '(:struct g-param-spec) (if owner 'owner-type 'type))) + (let ((struct (make-instance 'g-param-spec-struct + :pointer (pointer g-param-spec)))) + (if owner + (owner-type struct) + (g-param-spec-type struct)))) (defun show-properties (g-object) (let ((gclass (make-instance 'g-object-class :object g-object))) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/12/24 16:32:05 1.15 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp 2012/12/31 13:33:38 1.16 @@ -16,7 +16,7 @@ (:documentation "Lisp wrapper for GObject")) (defcstruct g-object - (g-type-instance (:pointer (:struct g-type-instance))) + (g-type-instance :pointer) ;; (:struct g-type-instance))) (ref-count :uint) (g-data :pointer)) @@ -145,8 +145,8 @@ (collect (value (make-instance 'g-value - :pointer (mem-aref - params '(:struct g-value-struct) i)))))) + :pointer (mem-aref + params 'g-value-struct i)))))) ; will be :struct (lisp-return (make-instance 'g-value :pointer return))) (let ((res (apply lisp-func lisp-params))) (when (/= (g-type lisp-return) 0) @@ -162,8 +162,8 @@ closure-ptr)) -(defcfun "g_signal_handler_disconnect" :void - (instance (:pointer (:struct g-object))) (id :ulong)) +(defcfun g-signal-handler-disconnect :void + (instance pobject) (id :ulong)) (defmethod connect ((g-object g-object) c-handler &key signal data after swapped) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2012/08/19 16:22:30 1.9 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp 2012/12/31 13:33:38 1.10 @@ -20,38 +20,37 @@ (defctype g-type :ulong "GType") -(defcstruct g-type-interface +(defcstruct* g-type-interface "GTypeInterface" - (g-type g-type) + (g-type-type g-type) (g-instance-type g-type)) -(defcstruct g-type-class +(defcstruct* g-type-class "GTypeClass" - (g-type g-type)) + (g-type-type g-type)) -(defcstruct g-type-instance +(defcstruct* g-type-instance "GTypeInstance" - (g-class (:pointer (:struct g-type-class)))) + (g-class (struct g-type-interface))) (defun g-type-from-instance (ptr) - (foreign-slot-value - (foreign-slot-value ptr '(:struct g-type-instance) 'g-class) - '(:struct g-type-class) 'g-type)) + (g-type-type (g-class (make-instance 'g-type-instance :pointer ptr + :free-after nil)))) (defcfun g-type-fundamental g-type (id g-type)) (defcfun g-type-from-name g-type (name :string)) (defcfun g-type-name :string (id :ulong)) -(defcstruct g-type-query +(defcstruct* g-type-query "GTypeQuery" - (type g-type) + (g-type-type g-type) (name :string) (class-size :uint) (instance-size :uint)) (defcfun g-type-query :void (type g-type) - (query (:pointer (:struct g-type-query)))) + (query (struct g-type-query))) (defun g-type->keyword (num) "Integer (GType) -> keyword from +fundamental-gtypes+" --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/10/07 12:02:11 1.8 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp 2012/12/31 13:33:38 1.9 @@ -22,10 +22,10 @@ (v-double :double) (v-pointer :pointer)) -(defcstruct g-value-struct +(defcstruct* g-value-struct "GValue struct" - (g-type :ulong) - (data (:union g-value-data) :count 2)) + (g-type-type :ulong) + (data g-value-data :count 2)) ;; with new CFFI -> (:union g-value-data) (defcfun "g_value_init" :pointer (g-value pobject) (type :int)) (defcfun "g_value_set_boolean" :void (g-value pobject) (val :boolean)) @@ -50,10 +50,11 @@ (defmethod gconstructor ((g-value g-value) &key (value nil value-p) g-type &allow-other-keys) - (let ((ptr (foreign-alloc '(:struct g-value-struct)))) - (setf (foreign-slot-value ptr '(:struct g-value-struct) 'g-type) 0) - (init-g-value ptr g-type value value-p) - ptr)) + (let ((struct (make-instance 'g-value-struct :new-struct t + :free-after nil))) + (setf (g-type-type struct) 0) + (init-g-value (pointer struct) g-type value value-p) + (pointer struct))) (defmethod (setf value) (val (g-value g-value)) (g-value-set g-value val (g-type g-value))) @@ -62,7 +63,7 @@ (defmethod unset ((g-value g-value)) ;(when (/= (g-type g-value) 0) - (format t "Unset value ~a~%" g-value) +; (format t "Unset value ~a~%" g-value) (g-value-unset g-value)) (defun init-g-value (ptr type value value-p) @@ -89,7 +90,7 @@ (g-value-set ptr value %type)))))) (defmethod init ((g-value g-value) &key (value nil value-p) g-type) - (format t "init ~a~%" g-value) +; (format t "init ~a~%" g-value) (init-g-value (pointer g-value) g-type value value-p)) @@ -98,7 +99,9 @@ Depends on implementation of GLib/GObject! Returns integer GType." (if (null-pointer-p value) 0 - (foreign-slot-value value '(:struct g-value-struct) 'g-type))) + (let ((struct (make-instance 'g-value-struct :pointer value + :free-after nil))) + (g-type-type struct)))) (defmethod g-type ((g-value g-value) &rest rest) (declare (ignore rest)) --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2012/10/07 12:02:11 1.12 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp 2012/12/31 13:33:38 1.13 @@ -74,6 +74,7 @@ #:find-child-property #:g-object-class + #:g-object-class-struct #:g-param-spec #:g-object-newv #:new --- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/subclass.lisp 2012/08/18 13:55:27 1.3 +++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/subclass.lisp 2012/12/31 13:33:38 1.4 @@ -28,7 +28,8 @@ (defcfun g-type-register-static g-type (parent-type g-type) (type-name :string) - (info (:pointer (:struct g-type-info))) (flags g-type-flags)) + (info :pointer) ; (:struct g-type-info))) + (flags g-type-flags)) (defcfun g-type-register-static-simple g-type (parent-type g-type) (type-name :string) (class-size :uint) @@ -43,7 +44,7 @@ (defcfun g-type-add-interface-static :void (instance-type g-type) (interface-type g-type) - (info (:pointer (:struct g-interface-info)))) + (info :pointer)); (:struct g-interface-info)))) \ No newline at end of file From rklochkov at common-lisp.net Mon Dec 31 13:33:38 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:33:38 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gdk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gdk In directory tiger.common-lisp.net:/tmp/cvs-serv30885/gdk Modified Files: color.lisp event.lisp keys.lisp pango.lisp Log Message: Backed to CFFI 10.7 (was version from git) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2012/08/24 19:27:54 1.9 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/color.lisp 2012/12/31 13:33:38 1.10 @@ -8,8 +8,8 @@ (blue :int16)) (defcfun gdk-color-parse :boolean (str :string) - (color (:pointer (:struct color-struct)))) -(defcfun gdk-color-to-string :string (color (:pointer (:struct color-struct)))) + (color :pointer)) +(defcfun gdk-color-to-string :string (color :pointer)) (defcfun gdk-color-free :void (color :pointer)) (define-foreign-type color-cffi (freeable) @@ -22,7 +22,7 @@ (defmethod translate-to-foreign (value (type color-cffi)) (if (pointerp value) value - (let ((color-st (foreign-alloc '(:struct color-struct)))) + (let ((color-st (foreign-alloc (cffi-objects::struct-type 'color-struct)))) (gdk-color-parse (string value) color-st) color-st))) @@ -44,9 +44,9 @@ (:actual-type :pointer) (:simple-parser prgba)) -(defcfun gdk-rgba-parse :boolean (color (:pointer (:struct rgba-struct))) +(defcfun gdk-rgba-parse :boolean (color :pointer) (str :string)) -(defcfun gdk-rgba-to-string :string (color (:pointer (:struct rgba-struct)))) +(defcfun gdk-rgba-to-string :string (color :pointer)) (defcfun gdk-rgba-free :void (color :pointer)) (defmethod free-ptr ((class (eql 'rgba-cffi)) ptr) @@ -54,7 +54,7 @@ (defmethod translate-to-foreign (value (type rgba-cffi)) (if (pointerp value) value - (let ((color-st (foreign-alloc '(:pointer (:struct rgba-struct))))) + (let ((color-st (foreign-alloc :pointer))) (assert (gdk-rgba-parse color-st (string value)) (value) "Bad RGBA color") color-st))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/event.lisp 2012/10/07 12:02:11 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/event.lisp 2012/12/31 13:33:38 1.6 @@ -120,14 +120,13 @@ (defctype region :pointer) ;; = GdkRegion* -(defcstruct event-expose - "" - (type event-type) +(defcstruct* event-expose + (event-expose-type event-type) (window window) (send-event :int8) (area (:struct rectangle)) (region region) - (count :int)) + (event-expose-count :int)) (defcenum visibility-state :unobscured :partial :obscured) @@ -237,7 +236,7 @@ (send-event :int8) (message-tyoe gdk-atom) (data-format :ushort) - (data (:union client-data-union))) + (data client-data-union)) ; :union (defcstruct event-no-expose "" @@ -292,26 +291,26 @@ (defcunion event (type event-type) - (any (:struct event-any)) - (expose (:struct event-expose)) - (no-expose (:struct event-no-expose)) - (visibility (:struct event-visibility)) - (motion (:struct event-motion)) - (button (:struct event-button)) - (scroll (:struct event-scroll)) - (key (:struct event-key)) - (crossing (:struct event-crossing)) - (focus-change (:struct event-focus)) - (configure (:struct event-configure)) - (property (:struct event-property)) - (selection (:struct event-selection)) - (owner-change (:struct event-owner-change)) - (proximity (:struct event-proximity)) - (client (:struct event-client)) - (dnd (:struct event-dnd)) - (window-state (:struct event-window-state)) - (setting (:struct event-setting)) - (grab-broken (:struct event-grab-broken))) + (any event-any) + (expose event-expose) + (no-expose event-no-expose) + (visibility event-visibility) + (motion event-motion) + (button event-button) + (scroll event-scroll) + (key event-key) + (crossing event-crossing) + (focus-change event-focus) + (configure event-configure) + (property event-property) + (selection event-selection) + (owner-change event-owner-change) + (proximity event-proximity) + (client event-client) + (dnd event-dnd) + (window-state event-window-state) + (setting event-setting) + (grab-broken event-grab-broken)) (defclass event (object) ((event-type :accessor event-type))) @@ -320,7 +319,7 @@ :after ((event event) &key pointer &allow-other-keys) (setf (event-type event) - (case (foreign-slot-value pointer '(:union event) 'type) + (case (foreign-slot-value pointer 'event 'type) ; :union ((:nothing :delete :destroy :map :unmap) 'event-any) (:expose 'event-expose) (:motion-notify 'event-motion) @@ -348,7 +347,8 @@ (t 'event-any)))) (defmethod get-slot ((event event) field) - (foreign-slot-value (pointer event) (list :struct (event-type event)) + (foreign-slot-value (pointer event) + (cffi-objects::struct-type (event-type event)) (find-symbol (string field) :gdk-cffi))) (defun parse-event (ev-pointer field) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/keys.lisp 2012/08/19 16:22:30 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/keys.lisp 2012/12/31 13:33:38 1.8 @@ -50,7 +50,7 @@ (level :int)) (defgdkfuns keymap - (lookup-key :uint (key (:pointer (:struct keymap-key)))) + (lookup-key :uint (key :pointer)) (:get direction pango-cffi:direction) (have-bidi-layouts :boolean) (:get caps-lock-state :boolean) --- /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2012/08/24 19:27:54 1.10 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gdk/pango.lisp 2012/12/31 13:33:38 1.11 @@ -168,45 +168,45 @@ :rise :shape :scale :fallback :letter-spacing :underline-color :strikethrough-color :absolute-size :gravity :gravity-hint)) -(defcstruct attribute +(defcstruct* attribute (klass (:pointer attr-type)) (start-index :uint) (end-index :uint)) -(defcstruct attr-string +(defcstruct* attr-string (attr (:struct attribute)) (value :string)) -(defcstruct attr-language +(defcstruct* attr-language (attr (:struct attribute)) (value language)) -(defcstruct color +(defcstruct* color (red :uint16) (green :uint16) (blue :uint16)) -(defcstruct attr-color +(defcstruct* attr-color (attr (:struct attribute)) (value (:struct color))) -(defcstruct attr-int +(defcstruct* attr-int (attr (:struct attribute)) (value :int)) -(defcstruct attr-float +(defcstruct* attr-float (attr (:struct attribute)) (value :float)) -(defcstruct attr-font-desc +(defcstruct* attr-font-desc (attr (:struct attribute)) (value font)) -(defcstruct rectangle +(defcstruct* rectangle (x :int) (y :int) (width :int) (height :int)) -(defcstruct attr-shape +(defcstruct* attr-shape (attr (:struct attribute)) (ink (:struct rectangle)) (logical (:struct rectangle)) @@ -214,13 +214,13 @@ (copy-func :pointer) (destroy-func :pointer)) -(defcstruct attr-size +(defcstruct* attr-size (attr (:struct attribute)) (size :int) (absolute :uint)) (defun rect->list (rect) - (with-foreign-slots ((x y width height) rect (:struct rectangle)) + (with-foreign-slots ((x y width height) rect rectangle) ; :struct (list x y width height))) (eval-when (:compile-toplevel :load-toplevel) @@ -244,35 +244,39 @@ (case type ((:style :weight :variant :stretch :underline :gravity :gravity-hint) (convert-from-foreign - value `(:struct ,(intern (symbol-name type) #.*package*)))) + value `(cffi-objects::struct-type + ,(intern (symbol-name type) #.*package*)))) ((:strikethrough :fallback) (convert-from-foreign value :boolean)) (t value))) (defun attr->list (attr) - (let* ((type (mem-ref (foreign-slot-value attr '(:struct attribute) 'klass) + (let* ((type (mem-ref (foreign-slot-value + attr (cffi-objects::struct-type 'attribute) 'klass) 'attr-type)) (tail-type (attr->type type))) - (with-foreign-slots ((start-index end-index) attr (:struct attribute)) + (with-foreign-slots ((start-index end-index) attr attribute) ; :struct (list* type start-index end-index (ecase tail-type ((attr-language attr-string attr-font-desc attr-float) - (list (foreign-slot-value attr `(:struct ,tail-type) 'value))) + (list (foreign-slot-value + attr (cffi-objects::struct-type tail-type) 'value))) (attr-int (list (translate-to-enum type - (foreign-slot-value attr `(:struct ,tail-type) - 'value)))) + (foreign-slot-value + attr (cffi-objects::struct-type tail-type) + 'value)))) (attr-color (with-foreign-slots ((red green blue) - (foreign-slot-value attr - '(:struct attr-color) - 'value) - (:struct color)) + (foreign-slot-value + attr (cffi-objects::struct-type 'attr-color) + 'value) + color) ; :struct (list red green blue))) (attr-size (list (foreign-slot-value attr tail-type 'size))) (attr-shape - (with-foreign-slots ((ink logical) attr (:struct attr-shape)) + (with-foreign-slots ((ink logical) attr attr-shape) ; :struct (list (rect->list ink) (rect->list logical))))))))) @@ -290,15 +294,15 @@ (:scale :double) (t (intern (symbol-name type) #.*package*))))) `(defcfun ,(symbolicate 'pango-attr- attr '-new) - (:pointer (:struct ,(attr->type attr))) (value ,(in-type attr))))) + :pointer (value ,(in-type attr))))) (template attr (:foreground :background :strikethrough-color :underline-color) `(defcfun ,(symbolicate 'pango-attr- attr '-new) - (:pointer (:struct attr-color)) (red :uint16) (green :uint16) + (struct attr-color) (red :uint16) (green :uint16) (blue :uint16))) (defcfun ("pango_attr_size_new_absolute" pango-attr-absolute-size-new) - (:pointer (:struct attr-size)) (size :int)) + (struct attr-size) (size :int)) (define-foreign-type rect-list (freeable) () @@ -306,8 +310,8 @@ (:actual-type :pointer)) (defmethod translate-to-foreign (value (type rect-list)) - (let ((ptr (foreign-alloc '(:pointer (:struct rectangle))))) - (with-foreign-slots ((x y width height) ptr (:struct rectangle)) + (let ((ptr (foreign-alloc :pointer))) + (with-foreign-slots ((x y width height) ptr rectangle) ; :struct (destructuring-bind (new-x new-y new-width new-height) value (setf x new-x y new-y @@ -316,7 +320,7 @@ ptr)) -(defcfun pango-attr-shape-new (:pointer (:struct attr-shape)) +(defcfun pango-attr-shape-new :pointer (ink rect-list) (logical rect-list)) (define-foreign-type attr-list (freeable) @@ -362,9 +366,9 @@ 'pango-attr- x '-new)))) (cdr (foreign-enum-keyword-list 'attr-type))))) params))) - (setf (foreign-slot-value ptr '(:struct attribute) + (setf (foreign-slot-value ptr (cffi-objects::struct-type 'attribute) 'start-index) start-index - (foreign-slot-value ptr '(:struct attribute) + (foreign-slot-value ptr (cffi-objects::struct-type 'attribute) 'end-index) end-index) ptr))) From rklochkov at common-lisp.net Mon Dec 31 13:33:38 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:33:38 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/gtk Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/gtk In directory tiger.common-lisp.net:/tmp/cvs-serv30885/gtk Modified Files: builder.lisp selections.lisp text-buffer.lisp tree-model.lisp tree-view.lisp widget.lisp Log Message: Backed to CFFI 10.7 (was version from git) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/builder.lisp 2012/08/19 16:19:26 1.4 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/builder.lisp 2012/12/31 13:33:38 1.5 @@ -14,19 +14,19 @@ (gtk-builder-new)) (defcfun gtk-builder-add-from-file :uint - (builder pobject) (filename :string) (g-error (:pointer (:struct g-error)))) + (builder pobject) (filename :string) (g-error :pointer)) (defcfun gtk-builder-add-from-string :uint (builder pobject) (string :string) (length gsize) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (defcfun gtk-builder-add-objects-from-file :uint (builder pobject) (filename :string) (object-ids string-list) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (defcfun gtk-builder-add-objects-from-string :uint (builder pobject) (string :string) (length gsize) (object-ids string-list) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (defgeneric add-from (builder &key filename string objects) (:method @@ -76,11 +76,11 @@ (defcfun gtk-builder-value-from-string :boolean (builder pobject) (pspec pobject) (string :string) (value pobject) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (defcfun gtk-builder-value-from-string-type :boolean (builder pobject) (g-type g-type) (string :string) (value pobject) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (defgeneric value-from-string (builder &key g-type param-spec string) (:method ((builder builder) &key g-type param-spec string) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/12/24 16:32:05 1.2 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/selections.lisp 2012/12/31 13:33:38 1.3 @@ -7,3 +7,19 @@ (target :string) (flags :uint) (info :uint)) + +(defcfun gtk-target-entry-new :pointer + (target :string) (flags :uint) (info :uint)) + +(defmethod gconstructor ((target-entry target-entry) + &key new-struct target flags info + &allow-other-keys) + (if new-struct + (gtk-target-entry-new target flags info) + (call-next-method))) + +(defcfun gtk-target-entry-free :void (ptr :pointer)) + +(defmethod free-struct ((class (eql 'target-entry)) ptr) + (gtk-target-entry-free ptr)) + --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2012/08/24 19:27:54 1.13 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/text-buffer.lisp 2012/12/31 13:33:38 1.14 @@ -445,7 +445,7 @@ (defcfun gtk-text-buffer-deserialize :boolean (register-buffer pobject) (content-buffer pobject) (format gatom) (text-iter pobject) (data (garray :uint8)) (length :int) - (err (:pointer (:struct g-error)))) + (err :pointer)) (define-condition deserialize-warning (warning) ((g-error :initarg g-error)) @@ -504,7 +504,7 @@ (iter (object text-buffer)) ;; object saves pointer, struct -- doesn't (array-data :pointer) (length :ulong) (create-tags :boolean) (user-data pdata) - (g-error (:pointer (:struct g-error)))) + (g-error :pointer)) (destructuring-bind (func data data-destroy) user-data (declare (ignore data-destroy)) (funcall func register-buffer content-buffer iter --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/12/15 14:33:10 1.17 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-model.lisp 2012/12/31 13:33:38 1.18 @@ -96,7 +96,7 @@ (defcstruct tree-model-iface "GtkTreeModelIface" - (g-iface (:struct g-type-interface)) + (g-iface g-type-interface) ; :struct (row-changed :pointer) (row-inserted :pointer) (has-child-toggled :pointer) @@ -123,7 +123,8 @@ (defmethod initialize-instance :after ((tree-model tree-model) &key &allow-other-keys) - (setf (tree-iter tree-model) (make-instance 'tree-iter :new-struct t))) + (setf (tree-iter tree-model) (make-instance 'tree-iter :new-struct t + :free-after nil))) (defmethod free :before ((tree-model tree-model)) (free (tree-iter tree-model))) --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/12/24 16:32:05 1.6 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/tree-view.lisp 2012/12/31 13:33:38 1.7 @@ -93,17 +93,6 @@ (save-setter tree-view columns) -(defcfun gtk-tree-view-get-path-at-pos :boolean (view pobject) - (x :int) (y :int) (path :pointer) (column :pointer) - (cell-x :pointer) (cell-y :pointer)) - -(defgeneric path-at-pos (tree-view x y) - (:method ((tree-view tree-view) x y) - (with-foreign-outs-list - ((path 'tree-path) (column 'pobject) - (cell-x :int) (cell-y :int)) :if-success - (gtk-tree-view-get-path-at-pos tree-view x y path column cell-x cell-y)))) - (defcfun gtk-tree-view-get-cursor :void (view pobject) (path :pointer) (column :pointer)) @@ -162,7 +151,7 @@ (tree-view pobject) (x :int) (y :int) (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) -(defcfun gtk-tree-view-path-at-pos :boolean +(defcfun gtk-tree-view-get-path-at-pos :boolean (tree-view pobject) (x :int) (y :int) (path :pointer) (column :pointer) (cell-x :pointer) (cell-y :pointer)) @@ -236,7 +225,10 @@ (def-coords tree widget) (def-coords widget bin-window) (def-coords widget tree)) - + +(defcfun gtk-tree-view-enable-model-drag-dest :void + (tree-view pobject) (targets (carray (struct target-entry))) + (n-targets :int) (action drag-action)) (init-slots tree-view (on-select) (when on-select --- /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/12/24 16:32:05 1.18 +++ /project/gtk-cffi/cvsroot/gtk-cffi/gtk/widget.lisp 2012/12/31 13:33:38 1.19 @@ -169,9 +169,9 @@ (accel-mods modifier-type)) (list-accel-closures g-list) (can-activate-accel :boolean (signal-id :uint)) - ((widget-event . event) :boolean (event (:pointer (:union event)))) - (send-expose :int (event (:pointer (:union event)))) - (send-focus-change :boolean (event (:pointer (:union event)))) + ((widget-event . event) :boolean (event :pointer)) + (send-expose :int (event :pointer)) + (send-focus-change :boolean (event :pointer)) (reparent :void (new-parent pobject)) (is-focus :boolean) (grab-focus :void) @@ -410,7 +410,7 @@ ()) (defcstruct widget-class - (parent-class (:struct g-object-class)) + (parent-class g-object-class-struct) ; :struct (activate-signal :pointer) (dispatch-child-properties-changed :pointer) (destroy :pointer) From rklochkov at common-lisp.net Mon Dec 31 13:55:22 2012 From: rklochkov at common-lisp.net (CVS User rklochkov) Date: Mon, 31 Dec 2012 05:55:22 -0800 Subject: [gtk-cffi-cvs] CVS gtk-cffi/ext Message-ID: Update of /project/gtk-cffi/cvsroot/gtk-cffi/ext In directory tiger.common-lisp.net:/tmp/cvs-serv1995/ext Modified Files: lisp-model.lisp package.lisp Log Message: Fixed gtk-ext --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/10/07 12:02:11 1.7 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/lisp-model.lisp 2012/12/31 13:55:22 1.8 @@ -259,7 +259,7 @@ :void ((class ,interface)) ,@(loop :for (callback args) :on callbacks :by #'cddr :collecting `(setf (foreign-slot-value class - '(:struct ,interface) + ',interface ; :struct ',callback) (callback ,(symbolicate '#:cb- callback))))))) @@ -269,8 +269,8 @@ get-n-columns (:int) get-column-type (:int (index :int)) get-iter (:boolean (iter (object tree-iter)) - (path cb-tree-path)) - get-path (cb-tree-path (iter (object tree-iter))) + (path ptree-path)) + get-path (ptree-path (iter (object tree-iter))) get-value (:void (iter (object tree-iter)) (n :int) (value :pointer)) iter-next (:boolean (iter (object tree-iter))) @@ -306,7 +306,7 @@ (g-type-register-static-simple #.(keyword->g-type :object) (g-intern-static-string "GtkLispModel") - (foreign-type-size 'g-object-class) + (foreign-type-size 'g-object-class-struct) (callback cb-lisp-model-class-init) (foreign-type-size 'g-object) (callback cb-lisp-model-init) --- /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/10/07 12:02:11 1.5 +++ /project/gtk-cffi/cvsroot/gtk-cffi/ext/package.lisp 2012/12/31 13:55:22 1.6 @@ -11,7 +11,7 @@ #:get-iter #:get-path #:get-value #:iter-next #:iter-previous #:iter-children #:iter-has-child #:iter-n-children #:get-flags #:iter-nth-child #:iter-parent #:ref-node #:unref-node - #:tree-path #:cb-tree-path) + #:tree-path #:ptree-path) (:export #:lisp-model #:implementation