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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gtkobject.lisp,v 1.30 2006-02-08 21:57:26 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28
  29 ;;;; Misc utils
  30
  31 ; (defun name-to-string (name)
  32 ;   (substitute #\_ #\- (string-downcase (string name))))
  33
  34 ; (defun string-to-name (name &optional (package "KEYWORD"))
  35 ;   (intern (substitute #\- #\_ (string-upcase name)) package))
  36
  37
  38
  39 ;;;; Superclass for the gtk class hierarchy
  40
  41 (eval-when (:compile-toplevel :load-toplevel :execute)
  42   (init-types-in-library
  43    #.(concatenate 'string (pkg-config:pkg-variable "gtk+-2.0" "libdir")
  44                           "/libgtk-x11-2.0.so"))
  45
  46   (defclass %object (gobject)
  47     ()
  48     (:metaclass gobject-class)
  49     (:gtype |gtk_object_get_type|)))
  50
  51
  52 (defmethod initialize-instance ((object %object) &rest initargs &key signal)
  53   (declare (ignore signal))
  54   (call-next-method)
  55   (dolist (signal-definition (get-all initargs :signal))
  56     (apply #'signal-connect object signal-definition)))
  57
  58 (defmethod initialize-instance :around ((object %object) &rest initargs)
  59   (declare (ignore initargs))
  60   (call-next-method)
  61   ;; Add a temorary reference which will be removed when the object is
  62   ;; sinked
  63   (reference-foreign (class-of object) (foreign-location object))
  64   (%object-sink object))
  65
  66 (defbinding %object-sink () nil
  67   (object %object))
  68
  69 ;;;; Main loop and event handling
  70
  71 (declaim (inline events-pending-p main-iteration))
  72
  73 (defbinding events-pending-p () boolean)
  74
  75 (defbinding get-current-event () gdk:event)
  76
  77 (defbinding main-do-event () nil
  78   (event gdk:event))
  79
  80 (defbinding main () nil)
  81
  82 (defbinding main-level () int)
  83
  84 (defbinding main-quit () nil)
  85
  86 (defbinding main-iteration-do (&optional (blocking t)) boolean
  87   (blocking boolean))
  88
  89 (defun main-iterate-all (&rest args)
  90   (declare (ignore args))
  91   (loop
  92    while (events-pending-p)
  93    do (main-iteration-do nil)))
  94
  95
  96 ;;;; Metaclass for child classes
  97
  98 (defvar *container-to-child-class-mappings* (make-hash-table))
  99
 100 (eval-when (:compile-toplevel :load-toplevel :execute)
 101   (defclass child-class (virtual-slots-class)
 102     ())
 103
 104   (defclass direct-child-slot-definition (direct-virtual-slot-definition)
 105     ((pname :reader slot-definition-pname :initarg :pname)))
 106
 107   (defclass effective-child-slot-definition (effective-virtual-slot-definition)
 108     ((pname :reader slot-definition-pname :initarg :pname)))
 109
 110
 111 (defmethod shared-initialize ((class child-class) names &key container)
 112   (call-next-method)
 113   (setf
 114    (gethash (find-class (first container)) *container-to-child-class-mappings*)
 115     class))
 116
 117 (defmethod direct-slot-definition-class ((class child-class) &rest initargs)
 118   (case (getf initargs :allocation)
 119     (:property (find-class 'direct-child-slot-definition))
 120     (t (call-next-method))))
 121
 122 (defmethod effective-slot-definition-class ((class child-class) &rest initargs)
 123   (case (getf initargs :allocation)
 124     (:property (find-class 'effective-child-slot-definition))
 125     (t (call-next-method))))
 126
 127 (defmethod compute-effective-slot-definition-initargs ((class child-class) direct-slotds)
 128   (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
 129       (nconc
 130        (list :pname (most-specific-slot-value direct-slotds 'pname))
 131        ;; Need this to prevent type type expansion in SBCL (>= 0.9.8)
 132        (list :type (most-specific-slot-value direct-slotds 'type))
 133        (call-next-method))
 134     (call-next-method)))
 135
 136 (progn
 137   #+cmu(declaim (optimize (inhibit-warnings 3)))
 138   #+sbcl(declaim (muffle-conditions compiler-note))
 139   (defun %container-child-get-property (parent child pname gvalue))
 140   (defun %container-child-set-property (parent child pname gvalue)))
 141
 142
 143 (defmethod initialize-internal-slot-functions ((slotd effective-child-slot-definition))
 144   (let ((type (slot-definition-type slotd))
 145         (pname (slot-definition-pname slotd)))
 146     (setf
 147      (slot-value slotd 'getter)
 148      #'(lambda (object)
 149          (with-slots (parent child) object
 150            (let ((gvalue (gvalue-new type)))
 151              (%container-child-get-property parent child pname gvalue)
 152              (unwind-protect
 153                  (funcall (reader-function type) gvalue +gvalue-value-offset+)
 154                (gvalue-free gvalue t))))))
 155
 156     (setf
 157      (slot-value slotd 'setter)
 158      #'(lambda (value object)
 159          (with-slots (parent child) object
 160            (let ((gvalue (gvalue-new type)))
 161              (funcall (writer-function type) value gvalue +gvalue-value-offset+)
 162              (%container-child-set-property parent child pname gvalue)
 163              (gvalue-free gvalue t)
 164              value)))))
 165
 166   (call-next-method)))
 167
 168
 169 (defmethod add-reader-method ((class child-class) generic-function slot-name)
 170   (add-method
 171    generic-function
 172    (make-instance 'standard-method
 173     :specializers (list (find-class 'widget))
 174     :lambda-list '(widget)
 175     :function #'(lambda (args next-methods)
 176                   (declare (ignore next-methods))
 177                   (child-property-value (first args) slot-name)))))
 178
 179 (defmethod add-writer-method
 180     ((class child-class) generic-function slot-name)
 181   (add-method
 182    generic-function
 183    (make-instance 'standard-method
 184     :specializers (list (find-class t) (find-class 'widget))
 185     :lambda-list '(value widget)
 186     :function #'(lambda (args next-methods)
 187                   (declare (ignore next-methods))
 188                   (destructuring-bind (value widget) args
 189                     (setf (child-property-value widget slot-name) value))))))
 190
 191
 192 (defmethod validate-superclass ((class child-class) (super standard-class))
 193   ;(subtypep (class-name super) 'container-child)
 194   t)
 195
 196
 197 (defclass container-child ()
 198   ((parent :initarg :parent :type container)
 199    (child :initarg :child :type widget)))
 200
 201
 202 ;;;;
 203
 204 (defbinding %container-class-list-child-properties () pointer
 205   (class pointer)
 206   (n-properties unsigned-int :out))
 207
 208 (defun query-container-class-child-properties (type-number)
 209   (let ((class (type-class-ref type-number)))
 210     (multiple-value-bind (array length)
 211         (%container-class-list-child-properties class)
 212       (unwind-protect
 213           (map-c-vector 'list #'identity array 'param length)
 214         (deallocate-memory array)))))
 215
 216 (defun default-container-child-name (container-class)
 217   (intern (format nil "~A-CHILD" container-class)))
 218
 219 (defun expand-container-type (type forward-p options)
 220   (let* ((class (type-from-number type))
 221          (super (supertype type))
 222          (child-class (default-container-child-name class)))
 223     (if forward-p
 224         (expand-gobject-type type t options)
 225       `(progn
 226          ,(expand-gobject-type type nil options)
 227          (defclass ,child-class (,(default-container-child-name super))
 228            ,(slot-definitions child-class
 229              (query-container-class-child-properties type) nil)
 230            (:metaclass child-class)
 231            (:container ,class))))))
 232
 233
 234 (register-derivable-type 'container "GtkContainer" 'expand-container-type 'gobject-dependencies)