chiark - git - mdw - clg/blob - gtk/gtkcontainer.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.no>
   3 ;;
   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.
   8 ;;
   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.
  13 ;;
  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
  17
  18 ;; $Id: gtkcontainer.lisp,v 1.1 2000-08-14 16:45:02 espen Exp $
  19
  20 (in-package "GTK")
  21
  22 (defclass container (widget)
  23   ((border-width
  24     :allocation :arg
  25     :accessor container-border-width
  26     :initarg :border-width
  27     :type unsigned-long)
  28    (resize-mode
  29     :allocation :arg
  30     :accessor container-resize-mode
  31     :initarg :resize-mode
  32     :type resize-mode)
  33    (children
  34     :allocation :virtual
  35     :location container-children
  36 ;    :initarg :children
  37     )
  38    (focus-child
  39     :allocation :virtual
  40     :location ("gtk_container_get_focus_child" "gtk_container_set_focus_child")
  41     :accessor container-focus-child
  42     :initarg :focus-child
  43     :type widget)
  44    (focus-hadjustment
  45     :allocation :virtual
  46     :location (nil "gtk_container_set_focus_hadjustment")
  47     :writer (setf container-focus-hadjustment)
  48     :initarg :focus-hadjustment
  49     :type adjustment)
  50    (focus-vadjustment
  51     :allocation :virtual
  52     :location (nil "gtk_container_set_focus_vadjustment")
  53     :writer (setf container-focus-vadjustment)
  54     :initarg :focus-vadjustment
  55     :type adjustment))
  56   (:metaclass widget-class)
  57   (:alien-name "GtkContainer"))
  58
  59
  60 (defmethod initialize-instance ((container container) &rest initargs
  61                                 &key children)
  62   (declare (ignore initargs))
  63   (call-next-method)
  64   (dolist (child children)
  65     (cond
  66      ((consp child)
  67       (container-add container (first child))
  68       (setf
  69        (slot-value (first child) 'child-slots)
  70        (apply
  71         #'make-instance
  72         (slot-value (class-of container) 'child-class)
  73         :parent container :child (first child) (cdr child))))
  74      (t
  75       (container-add container child)))))
  76
  77
  78
  79 (define-foreign ("gtk_container_child_getv" container-child-get-arg) () nil
  80   (container container)
  81   (child widget)
  82   (1 unsigned-int)
  83   (arg arg))
  84
  85 (define-foreign ("gtk_container_child_setv" container-child-set-arg) () nil
  86   (container container)
  87   (child widget)
  88   (1 unsigned-int)
  89   (arg arg))
  90
  91 (defun container-child-arg (container child name)
  92   (with-gc-disabled
  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))))
  97         (prog1
  98             (arg-value arg type)
  99           (arg-free arg nil))))))
 100
 101 (defun (setf container-child-arg) (value container child name)
 102   (with-gc-disabled
 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))))
 110   value)
 111
 112
 113 (define-foreign container-add () nil
 114   (container container)
 115   (widget widget))
 116
 117 (define-foreign container-remove () nil
 118   (container container)
 119   (widget widget))
 120
 121 (define-foreign container-check-resize () nil
 122   (container container))
 123
 124 (define-foreign ("gtk_container_foreach_full" %container-foreach)
 125     (container function) nil
 126   (container container)
 127   (0 unsigned-long)
 128   (*callback-marshal* pointer)
 129   ((register-callback-function function) unsigned-long)
 130   (*destroy-marshal* pointer))
 131
 132 (defun map-container (seqtype func container)
 133   (case seqtype
 134     ((nil)
 135      (%container-foreach container func)
 136      nil)
 137     (list
 138      (let ((list nil))
 139        (%container-foreach
 140         container
 141         #'(lambda (child)
 142             (push (funcall func child) list)))
 143        (nreverse list)))
 144     (t
 145      (let ((seq (make-sequence seqtype (container-num-children container)))
 146            (index 0))
 147        (%container-foreach
 148         container
 149         #'(lambda (child)
 150             (setf (elt seq index) (funcall func child))
 151             (incf index)))
 152        seq))))
 153
 154 (defmacro do-container ((var container &optional (result nil)) &body body)
 155   (let ((continue (make-symbol "CONTINUE")))
 156     `(let ((,continue t))
 157        (%container-foreach
 158         ,container
 159         #'(lambda (,var)
 160             (when ,continue
 161               (setq ,continue nil)
 162               (block nil
 163                 ,@body
 164                 (setq ,continue t)))))
 165        ,result)))
 166
 167 (define-foreign container-children () (double-list widget)
 168   (container container))
 169
 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))
 175   children)
 176
 177 ;; Should be implemented as a foreign function
 178 (defun container-num-children (container)
 179   (length (container-children container)))
 180
 181 (define-foreign container-resize-children () nil
 182   (container container))