X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/560af5c515eb5b6206040a9334de4254d2650147..34f9e1d49c0b952ab3042362c54d85520992927f:/gtk/gtkcontainer.lisp diff --git a/gtk/gtkcontainer.lisp b/gtk/gtkcontainer.lisp index 5b47b2c..530b1b4 100644 --- a/gtk/gtkcontainer.lisp +++ b/gtk/gtkcontainer.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,136 +15,89 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: gtkcontainer.lisp,v 1.1 2000-08-14 16:45:02 espen Exp $ +;; $Id: gtkcontainer.lisp,v 1.10 2004-11-01 00:08:50 espen Exp $ (in-package "GTK") - -(defclass container (widget) - ((border-width - :allocation :arg - :accessor container-border-width - :initarg :border-width - :type unsigned-long) - (resize-mode - :allocation :arg - :accessor container-resize-mode - :initarg :resize-mode - :type resize-mode) - (children - :allocation :virtual - :location container-children -; :initarg :children - ) - (focus-child - :allocation :virtual - :location ("gtk_container_get_focus_child" "gtk_container_set_focus_child") - :accessor container-focus-child - :initarg :focus-child - :type widget) - (focus-hadjustment - :allocation :virtual - :location (nil "gtk_container_set_focus_hadjustment") - :writer (setf container-focus-hadjustment) - :initarg :focus-hadjustment - :type adjustment) - (focus-vadjustment - :allocation :virtual - :location (nil "gtk_container_set_focus_vadjustment") - :writer (setf container-focus-vadjustment) - :initarg :focus-vadjustment - :type adjustment)) - (:metaclass widget-class) - (:alien-name "GtkContainer")) - - -(defmethod initialize-instance ((container container) &rest initargs - &key children) - (declare (ignore initargs)) + +(defmethod shared-initialize ((container container) names &rest initargs + &key child children child-args) + (declare (ignore child)) (call-next-method) - (dolist (child children) - (cond - ((consp child) - (container-add container (first child)) - (setf - (slot-value (first child) 'child-slots) - (apply - #'make-instance - (slot-value (class-of container) 'child-class) - :parent container :child (first child) (cdr child)))) - (t - (container-add container child))))) + (dolist (child (append children (get-all initargs :child))) + (apply #'container-add container (append (mklist child) child-args)))) + + +(defbinding %container-add () nil + (container container) + (widget widget)) +(defmethod container-add ((container container) (widget widget) &rest args) + (%container-add container widget) + (when args + (setf + (slot-value widget 'child-slots) + (apply + #'make-instance + (gethash (class-of container) *container-to-child-class-mappings*) + :parent container :child widget args)))) -(define-foreign ("gtk_container_child_getv" container-child-get-arg) () nil +(defbinding %container-remove () nil (container container) - (child widget) - (1 unsigned-int) - (arg arg)) + (widget widget)) -(define-foreign ("gtk_container_child_setv" container-child-set-arg) () nil +(defmethod container-remove ((container container) (widget widget)) + (%container-remove container widget) + (slot-makunbound widget 'child-slots)) + + +(defbinding %container-child-get-property () nil (container container) (child widget) - (1 unsigned-int) - (arg arg)) - -(defun container-child-arg (container child name) - (with-gc-disabled - (let ((arg (arg-new 0))) - (setf (arg-name arg) name) - (container-child-get-arg container child arg) ; probably memory leak - (let ((type (type-from-number (arg-type arg)))) - (prog1 - (arg-value arg type) - (arg-free arg nil)))))) - -(defun (setf container-child-arg) (value container child name) - (with-gc-disabled - (let ((arg (arg-new 0))) - (setf (arg-name arg) name) - (container-child-get-arg container child arg) ; probably memory leak - (let ((type (type-from-number (arg-type arg)))) - (setf (arg-value arg type) value) - (container-child-set-arg container child arg) - (arg-free arg nil)))) - value) - - -(define-foreign container-add () nil - (container container) - (widget widget)) + (property-name string) + (value gvalue)) -(define-foreign container-remove () nil +(defbinding %container-child-set-property () nil (container container) - (widget widget)) + (child widget) + (property-name string) + (value gvalue)) + -(define-foreign container-check-resize () nil +(defbinding container-check-resize () nil (container container)) -(define-foreign ("gtk_container_foreach_full" %container-foreach) - (container function) nil +(def-callback %foreach-callback (c-call:void (widget system-area-pointer) + (callback-id c-call:unsigned-int)) + (invoke-callback callback-id nil (ensure-proxy-instance 'widget widget nil))) + +(defbinding %container-foreach (container callback-id) nil (container container) - (0 unsigned-long) - (*callback-marshal* pointer) - ((register-callback-function function) unsigned-long) - (*destroy-marshal* pointer)) + ((callback %foreach-callback) pointer) + (callback-id unsigned-int)) + +(defun container-foreach (container function) + (let ((callback-id (register-callback-function function))) + (unwind-protect + (%container-foreach container callback-id) + (destroy-user-data callback-id)))) (defun map-container (seqtype func container) (case seqtype ((nil) - (%container-foreach container func) + (container-foreach container func) nil) (list (let ((list nil)) - (%container-foreach + (container-foreach container #'(lambda (child) (push (funcall func child) list))) (nreverse list))) (t - (let ((seq (make-sequence seqtype (container-num-children container))) + (let ((seq (make-sequence seqtype (container-length container))) (index 0)) - (%container-foreach + (container-foreach container #'(lambda (child) (setf (elt seq index) (funcall func child)) @@ -154,7 +107,7 @@ (defun map-container (seqtype func container) (defmacro do-container ((var container &optional (result nil)) &body body) (let ((continue (make-symbol "CONTINUE"))) `(let ((,continue t)) - (%container-foreach + (container-foreach ,container #'(lambda (,var) (when ,continue @@ -164,19 +117,54 @@ (defmacro do-container ((var container &optional (result nil)) &body body) (setq ,continue t))))) ,result))) -(define-foreign container-children () (double-list widget) - (container container)) +;; (defbinding %container-get-children () (glist widget) +;; (container container)) -(defun (setf container-children) (children container) +(defmethod container-children ((container container)) +;; (%container-get-children container) + (map-container 'list #'identity container)) + +(defmethod (setf container-children) (children (container container)) (dolist (child (container-children container)) (container-remove container child)) (dolist (child children) (container-add container child)) children) -;; Should be implemented as a foreign function -(defun container-num-children (container) - (length (container-children container))) +(defun container-length (container) + (let ((n 0)) + (container-foreach container + #'(lambda (child) + (declare (ignore child)) + (incf n))) + n)) -(define-foreign container-resize-children () nil +(defbinding container-resize-children () nil (container container)) + +(defbinding container-propagate-expose () nil + (container container) + (child widget) + (event gdk:expose-event)) + + +(defbinding %container-get-focus-chain () boolean + (container container) + (focusable-widgets (glist widget) :out)) + +(defun container-focus-chain (container) + (multiple-value-bind (chain-set-p focusable-widgets) + (%container-get-focus-chain container) + (and chain-set-p focusable-widgets))) + +(defbinding %container-set-focus-chain () nil + (container container) + (focusable-widgets (glist widget))) + +(defbinding %container-unset-focus-chain () nil + (container container)) + +(defun (setf container-focus-chain) (focusable-widgets container) + (if (null focusable-widgets) + (%container-unset-focus-chain container) + (%container-set-focus-chain container focusable-widgets)))