1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
4 ;; This library is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU Lesser General Public
6 ;; License as published by the Free Software Foundation; either
7 ;; version 2 of the License, or (at your option) any later version.
9 ;; This library is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; You should have received a copy of the GNU Lesser General Public
15 ;; License along with this library; if not, write to the Free Software
16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 ;; $Id: gtkcontainer.lisp,v 1.1 2000-08-14 16:45:02 espen Exp $
22 (defclass container (widget)
25 :accessor container-border-width
26 :initarg :border-width
30 :accessor container-resize-mode
35 :location container-children
40 :location ("gtk_container_get_focus_child" "gtk_container_set_focus_child")
41 :accessor container-focus-child
46 :location (nil "gtk_container_set_focus_hadjustment")
47 :writer (setf container-focus-hadjustment)
48 :initarg :focus-hadjustment
52 :location (nil "gtk_container_set_focus_vadjustment")
53 :writer (setf container-focus-vadjustment)
54 :initarg :focus-vadjustment
56 (:metaclass widget-class)
57 (:alien-name "GtkContainer"))
60 (defmethod initialize-instance ((container container) &rest initargs
62 (declare (ignore initargs))
64 (dolist (child children)
67 (container-add container (first child))
69 (slot-value (first child) 'child-slots)
72 (slot-value (class-of container) 'child-class)
73 :parent container :child (first child) (cdr child))))
75 (container-add container child)))))
79 (define-foreign ("gtk_container_child_getv" container-child-get-arg) () nil
85 (define-foreign ("gtk_container_child_setv" container-child-set-arg) () nil
91 (defun container-child-arg (container child name)
93 (let ((arg (arg-new 0)))
94 (setf (arg-name arg) name)
95 (container-child-get-arg container child arg) ; probably memory leak
96 (let ((type (type-from-number (arg-type arg))))
99 (arg-free arg nil))))))
101 (defun (setf container-child-arg) (value container child name)
103 (let ((arg (arg-new 0)))
104 (setf (arg-name arg) name)
105 (container-child-get-arg container child arg) ; probably memory leak
106 (let ((type (type-from-number (arg-type arg))))
107 (setf (arg-value arg type) value)
108 (container-child-set-arg container child arg)
109 (arg-free arg nil))))
113 (define-foreign container-add () nil
114 (container container)
117 (define-foreign container-remove () nil
118 (container container)
121 (define-foreign container-check-resize () nil
122 (container container))
124 (define-foreign ("gtk_container_foreach_full" %container-foreach)
125 (container function) nil
126 (container container)
128 (*callback-marshal* pointer)
129 ((register-callback-function function) unsigned-long)
130 (*destroy-marshal* pointer))
132 (defun map-container (seqtype func container)
135 (%container-foreach container func)
142 (push (funcall func child) list)))
145 (let ((seq (make-sequence seqtype (container-num-children container)))
150 (setf (elt seq index) (funcall func child))
154 (defmacro do-container ((var container &optional (result nil)) &body body)
155 (let ((continue (make-symbol "CONTINUE")))
156 `(let ((,continue t))
164 (setq ,continue t)))))
167 (define-foreign container-children () (double-list widget)
168 (container container))
170 (defun (setf container-children) (children container)
171 (dolist (child (container-children container))
172 (container-remove container child))
173 (dolist (child children)
174 (container-add container child))
177 ;; Should be implemented as a foreign function
178 (defun container-num-children (container)
179 (length (container-children container)))
181 (define-foreign container-resize-children () nil
182 (container container))