X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/cc74b2c987edc3e2bc85413e92f33e2690a32b1c..b6d4ac86c7f32c64e5a0debea5ad93f2f00672e7:/gtk/gtktree.lisp diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp index 9b408f5..503b5c5 100644 --- a/gtk/gtktree.lisp +++ b/gtk/gtktree.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtktree.lisp,v 1.13 2006-02-08 22:21:07 espen Exp $ +;; $Id: gtktree.lisp,v 1.19 2006-04-26 12:13:38 espen Exp $ (in-package "GTK") @@ -58,15 +58,15 @@ (defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil ((string-downcase attribute) string) (column int)) -(def-callback-marshal %cell-layout-data-func - (nil cell-layout cell-renderer tree-model (copy-of tree-iter))) +(define-callback-marshal %cell-layout-data-callback nil + (cell-layout cell-renderer tree-model tree-iter)) (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil (cell-layout cell-layout) (cell cell-renderer) - (%cell-layout-data-func callback) + (%cell-layout-data-callback callback) ((register-callback-function function) unsigned-int) - (user-data-destroy-func callback)) + (user-data-destroy-callback callback)) (defbinding cell-layout-clear-attributes () nil (cell-layout cell-layout) @@ -81,13 +81,16 @@ (defmethod initialize-instance ((list-store list-store) &key column-types (call-next-method) (%list-store-set-column-types list-store column-types) (when column-names - (setf (object-data list-store 'column-names) column-names)) + (setf + (user-data list-store 'column-names) + (coerce column-names 'vector))) (when initial-content (loop with iter = (make-instance 'tree-iter) for row in initial-content do (list-store-append list-store row iter)))) +(defgeneric column-setter-name (store)) (defmethod column-setter-name ((list-store list-store)) (declare (ignore list-store)) @@ -207,7 +210,7 @@ (defbinding %tree-path-get-depth () int (location pointer)) (defun %make-tree-path (path) - (let ((c-vector (make-c-vector 'int (length path) path)) + (let ((c-vector (make-c-vector 'int (length path) :content path)) (location (allocate-memory (+ (size-of 'int) (size-of 'pointer))))) (funcall (writer-function 'int) (length path) location) (funcall (writer-function 'pointer) c-vector location (size-of 'int)) @@ -220,82 +223,96 @@ (defun %tree-path-to-vector (location) #() (map-c-vector 'vector #'identity indices 'int depth)))) +(defmacro %with-tree-path ((var path) &body body) + (let ((vector-offset (+ (size-of 'int) (size-of 'pointer)))) + `(with-memory (,var (+ ,(size-of 'int) ,(size-of 'pointer) (* ,(size-of 'int) (length ,path)))) + (funcall (writer-function 'int) (length ,path) ,var) + (setf (ref-pointer ,var ,(size-of 'int)) (pointer+ ,var ,vector-offset)) + (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset)) + ,@body))) + (eval-when (:compile-toplevel :load-toplevel :execute) - (defmethod alien-type ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method alien-type ((type tree-path)) + (declare (ignore type)) (alien-type 'pointer)) - (defmethod size-of ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method size-of ((type tree-path) &key inlined) + (assert-not-inlined type inlined) (size-of 'pointer)) - (defmethod to-alien-form (path (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) + (define-type-method alien-arg-wrapper ((type tree-path) var path style form &optional copy-in-p) + (declare (ignore type)) + (cond + ((and (in-arg-p style) copy-in-p) + `(with-pointer (,var (%make-tree-path ,path)) + ,form)) + ((and (in-arg-p style) (not (out-arg-p style))) + `(%with-tree-path (,var ,path) + ,form)) + ((and (in-arg-p style) (out-arg-p style)) + (let ((tree-path (make-symbol "SYMBOL"))) + `(%with-tree-path (,tree-path ,path) + (with-pointer (,var ,tree-path) + ,form)))) + ((and (out-arg-p style) (not (in-arg-p style))) + `(with-pointer (,var) + ,form)))) + + (define-type-method to-alien-form ((type tree-path) path &optional copy-p) + (declare (ignore type copy-p)) `(%make-tree-path ,path)) - (defmethod from-alien-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - `(let ((location ,location)) - (prog1 - (%tree-path-to-vector location) - (%tree-path-free location)))) - - (defmethod copy-from-alien-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - `(%tree-path-to-vector ,location)) + (define-type-method from-alien-form ((type tree-path) location &key (ref :free)) + (declare (ignore type)) + `(prog1 + (%tree-path-to-vector ,location) + ,(when (eq ref :free) + `(%tree-path-free ,location))))) - (defmethod cleanup-form (location (type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - `(%tree-path-free ,location))) - -(defmethod to-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - #'%make-tree-path) - -(defmethod from-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - #'(lambda (location) - (prog1 - (%tree-path-to-vector location) +(define-type-method to-alien-function ((type tree-path) &optional copy-p) + (declare (ignore type)) + #'%make-tree-path + (unless copy-p + #'(lambda (tree-path location) + (declare (ignore tree-path)) (%tree-path-free location)))) - -(defmethod copy-from-alien-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - #'%tree-path-to-vector) -(defmethod cleanup-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - #'%tree-path-free) - -(defmethod writer-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) +(define-type-method from-alien-function ((type tree-path) &key (ref :free)) + (declare (ignore type)) + (if (eq ref :free) + #'(lambda (location) + (prog1 + (%tree-path-to-vector location) + (%tree-path-free location))) + #'(lambda (location) + (%tree-path-to-vector location)))) + +(define-type-method writer-function ((type tree-path) &key temp inlined) + (declare (ignore temp)) + (assert-not-inlined type inlined) (let ((writer (writer-function 'pointer))) #'(lambda (path location &optional (offset 0)) (funcall writer (%make-tree-path path) location offset)))) -(defmethod reader-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - (let ((reader (reader-function 'pointer))) - #'(lambda (location &optional (offset 0) weak-p) - (declare (ignore weak-p)) - (%tree-path-to-vector (funcall reader location offset))))) +(define-type-method reader-function ((type tree-path) &key ref inlined) + (declare (ignore ref)) + (assert-not-inlined type inlined) + #'(lambda (location &optional (offset 0)) + (%tree-path-to-vector (ref-pointer location offset)))) -(defmethod destroy-function ((type (eql 'tree-path)) &rest args) - (declare (ignore type args)) - (let ((reader (reader-function 'pointer))) - #'(lambda (location &optional (offset 0)) - (%tree-path-free (funcall reader location offset))))) +(define-type-method destroy-function ((type tree-path) &key temp inlined) + (declare (ignore temp)) + (assert-not-inlined type inlined) + #'(lambda (location &optional (offset 0)) + (%tree-path-free (ref-pointer location offset)))) (defbinding %tree-row-reference-new () pointer (model tree-model) (path tree-path)) -(defmethod initialize-instance ((reference tree-row-reference) &key model path) - (setf - (foreign-location reference) - (%tree-row-reference-new model path)) - (call-next-method)) +(defmethod allocate-foreign ((reference tree-row-reference) &key model path) + (%tree-row-reference-new model path)) (defbinding tree-row-reference-get-path () tree-path (reference tree-row-reference)) @@ -311,7 +328,7 @@ (defbinding tree-model-get-column-type () gtype ;type-number (defbinding tree-model-get-iter (model path &optional (iter (make-instance 'tree-iter))) boolean (model tree-model) - (iter tree-iter :return) + (iter tree-iter :in/return) (path tree-path)) (defbinding tree-model-get-path () tree-path @@ -324,7 +341,9 @@ (defbinding %tree-model-get-value () nil (column int) (gvalue gvalue)) -(defun tree-model-value (model row column) +(defgeneric tree-model-value (model row column)) + +(defmethod tree-model-value ((model tree-model) row column) (let ((index (column-index model column)) (iter (etypecase row (tree-iter row) @@ -338,12 +357,12 @@ (defun tree-model-value (model row column) (defbinding tree-model-iter-next () boolean (tree-model tree-model) - (iter tree-iter :return)) + (iter tree-iter :in/return)) (defbinding tree-model-iter-children (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean (tree-model tree-model) - (iter tree-iter :return) + (iter tree-iter :in/return) (parent (or null tree-iter))) (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child") @@ -358,22 +377,22 @@ (defbinding tree-model-iter-n-children () int (defbinding tree-model-iter-nth-child (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean (tree-model tree-model) - (iter tree-iter :return) + (iter tree-iter :in/return) (parent (or null tree-iter)) (n int)) (defbinding tree-model-iter-parent (tree-model child &optional (iter (make-instance 'tree-iter))) boolean (tree-model tree-model) - (iter tree-iter :return) + (iter tree-iter :in/return) (child tree-iter)) -(def-callback-marshal %tree-model-foreach-func - (boolean tree-model (path (copy-of tree-path)) (iter (copy-of tree-iter)))) +(define-callback-marshal %tree-model-foreach-callback boolean + (tree-model tree-path tree-iter)) -(defbinding %tree-model-foreach () nil +(defbinding %tree-model-foreach (tree-model callback-id) nil (tree-model tree-model) - ((progn %tree-model-foreach-func) callback) + (%tree-model-foreach-callback callback) (callback-id unsigned-int)) (defun tree-model-foreach (model function) @@ -408,6 +427,7 @@ (defbinding tree-model-rows-reordered () nil (defun column-types (model columns) + (declare (ignore model)) (map 'vector #'(lambda (column) (find-type-number (first (mklist column)))) @@ -417,19 +437,19 @@ (defun column-index (model column) (or (etypecase column (number column) - (symbol (position column (object-data model 'column-names))) - (string (position column (object-data model 'column-names) + (symbol (position column (user-data model 'column-names))) + (string (position column (user-data model 'column-names) :test #'string=))) (error "~A has no column ~S" model column))) (defun column-name (model index) - (svref (object-data model 'column-names) index)) + (svref (user-data model 'column-names) index)) (defun tree-model-column-value-setter (model column) (let ((setters (or - (object-data model 'column-setters) + (user-data model 'column-setters) (setf - (object-data model 'column-setters) + (user-data model 'column-setters) (make-array (tree-model-n-columns model) :initial-element nil))))) (let ((index (column-index model column))) @@ -440,7 +460,6 @@ (defun tree-model-column-value-setter (model column) (let ((setter (mkbinding (column-setter-name model) nil (type-of model) 'tree-iter 'int -; (type-from-number (tree-model-get-column-type model index)) (tree-model-get-column-type model index) 'int))) #'(lambda (value iter) @@ -448,21 +467,23 @@ (defun tree-model-column-value-setter (model column) (defun tree-model-row-setter (model) (or - (object-data model 'row-setter) + (user-data model 'row-setter) (progn ;; This will create any missing column setter (loop for i from 0 below (tree-model-n-columns model) do (tree-model-column-value-setter model i)) - (let ((setters (object-data model 'column-setters))) + (let ((setters (user-data model 'column-setters))) (setf - (object-data model 'row-setter) + (user-data model 'row-setter) #'(lambda (row iter) (map nil #'(lambda (value setter) (funcall setter value iter)) row setters))))))) -(defun (setf tree-model-value) (value model row column) +(defgeneric (setf tree-model-value) (value model row column)) + +(defmethod (setf tree-model-value) (value (model tree-model) row column) (let ((iter (etypecase row (tree-iter row) (tree-path (multiple-value-bind (valid iter) @@ -489,25 +510,26 @@ (defun %tree-model-set (model iter data) ;;; Tree Selection -(def-callback-marshal %tree-selection-func (boolean tree-selection tree-model (path (copy-of tree-path)) (path-currently-selected boolean))) +(define-callback-marshal %tree-selection-callback boolean + (tree-selection tree-model tree-path (path-currently-selected boolean))) (defbinding tree-selection-set-select-function (selection function) nil (selection tree-selection) - (%tree-selection-func callback) + (%tree-selection-callback callback) ((register-callback-function function) unsigned-int) - (user-data-destroy-func callback)) + (user-data-destroy-callback callback)) (defbinding tree-selection-get-selected (selection &optional (iter (make-instance 'tree-iter))) boolean (selection tree-selection) (nil null) - (iter tree-iter :return)) + (iter tree-iter :in/return)) -(def-callback-marshal %tree-selection-foreach-func (nil tree-model (path (copy-of tree-path)) (iter (copy-of tree-iter)))) +(define-callback-marshal %tree-selection-foreach-callback nil (tree-model tree-path tree-iter)) -(defbinding %tree-selection-selected-foreach () nil +(defbinding %tree-selection-selected-foreach (tree-selection callback-id) nil (tree-selection tree-selection) - ((progn %tree-selection-foreach-func) callback) + (%tree-selection-foreach-callback callback) (callback-id unsigned-int)) (defun tree-selection-selected-foreach (selection function) @@ -584,8 +606,8 @@ (define-enum-type sort-column (:default -1) (:unsorted -2)) (define-enum-type sort-order (:before -1) (:equal 0) (:after 1))) -(def-callback-marshal %tree-iter-compare-func - ((or int sort-order) tree-model (a (copy-of tree-iter)) (b (copy-of tree-iter)))) +(define-callback-marshal %tree-iter-compare-callback (or int sort-order) + (tree-model (a tree-iter) (b tree-iter))) (defbinding tree-sortable-sort-column-changed () nil (sortable tree-sortable)) @@ -617,15 +639,15 @@ (defbinding (tree-sortable-set-sort-column (defbinding %tree-sortable-set-sort-func (sortable column function) nil (sortable tree-sortable) ((column-index sortable column) int) - (%tree-iter-compare-func callback) + (%tree-iter-compare-callback callback) ((register-callback-function function) unsigned-int) - (user-data-destroy-func callback)) + (user-data-destroy-callback callback)) (defbinding %tree-sortable-set-default-sort-func () nil (sortable tree-sortable) - (compare-func (or null pointer)) + (compare-func (or null callback)) (callback-id unsigned-int) - (destroy-func (or null pointer))) + (destroy-func (or null callback))) (defun tree-sortable-set-sort-func (sortable column function) "Sets the comparison function used when sorting to be FUNCTION. If @@ -636,9 +658,9 @@ (defun tree-sortable-set-sort-func (sortable column function) (%tree-sortable-set-default-sort-func sortable nil 0 nil)) ((eq column :default) (%tree-sortable-set-default-sort-func sortable - (callback %tree-iter-compare-func) + %tree-iter-compare-callback (register-callback-function function) - (callback user-data-destroy-func))) + user-data-destroy-callback)) ((%tree-sortable-set-sort-func sortable column function)))) (defbinding tree-sortable-has-default-sort-func-p () boolean @@ -657,7 +679,7 @@ (defmethod initialize-instance ((tree-store tree-store) &key column-types (call-next-method) (%tree-store-set-column-types tree-store column-types) (when column-names - (setf (object-data tree-store 'column-names) column-names))) + (setf (user-data tree-store 'column-names) column-names))) (defmethod column-setter-name ((tree-store tree-store)) (declare (ignore tree-store)) @@ -764,6 +786,7 @@ (defbinding tree-store-move-after () nil (defmethod initialize-instance ((tree-view tree-view) &rest initargs &key column) + (declare (ignore column)) (call-next-method) (mapc #'(lambda (column) (tree-view-append-column tree-view column)) @@ -852,11 +875,11 @@ (defbinding tree-view-collapse-row () nil (tree-view tree-view) (path tree-path)) -(def-callback-marshal %tree-view-mapping-func (nil tree-view (path (copy-of tree-path)))) +(define-callback-marshal %tree-view-mapping-callback nil (tree-view tree-path)) -(defbinding %tree-view-map-expanded-rows () nil +(defbinding %tree-view-map-expanded-rows (tree-view callback-id) nil (tree-view tree-view) - ((progn %tree-view-mapping-func) callback) + (%tree-view-mapping-callback callback) (callback-id unsigned-int)) (defun map-expanded-rows (function tree-view) @@ -881,35 +904,34 @@ (defbinding tree-view-get-cell-area () nil (tree-view tree-view) (path (or null tree-path)) (column (or null tree-view-column)) - ((make-instance 'gdk:rectangle) gdk:rectangle :return)) + ((make-instance 'gdk:rectangle) gdk:rectangle :in/return)) (defbinding tree-view-get-background-area () nil (tree-view tree-view) (path (or null tree-path)) (column (or null tree-view-column)) - ((make-instance 'gdk:rectangle) gdk:rectangle :return)) + ((make-instance 'gdk:rectangle) gdk:rectangle :in/return)) (defbinding tree-view-get-visible-rect () nil (tree-view tree-view) - ((make-instance 'gdk:rectangle) gdk:rectangle :return)) + ((make-instance 'gdk:rectangle) gdk:rectangle :in/return)) ;; and many more functions which we'll add later ;;;; Icon View -#+gtk2.6 +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0") (progn (defbinding icon-view-get-path-at-pos () tree-path (icon-view icon-view) (x int) (y int)) - (def-callback-marshal %icon-view-foreach-func - (nil icon-view (path (copy-of tree-path)))) + (define-callback-marshal %icon-view-foreach-callback nil (icon-view tree-path)) - (defbinding %icon-view-selected-foreach () tree-path + (defbinding %icon-view-selected-foreach (icon-view callback-id) tree-path (icon-view icon-view) - ((progn %icon-view-foreach-func) callback) + (%icon-view-foreach-callback callback) (callback-id unsigned-int)) (defun icon-view-foreach (icon-view function) @@ -959,7 +981,7 @@ (defbinding %icon-view-set-pixbuf-column (column icon-view) nil column (column-index (icon-view-model icon-view) column)) int))) -#+gtk2.8 +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0") (progn (defbinding icon-view-get-item-at-pos () boolean (icon-view icon-view)