chiark - git - mdw - clg/blob - glib/ginterface.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2001-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: ginterface.lisp,v 1.16 2006-02-28 00:11:24 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 (use-prefix "g")
  28
  29 ;;;;
  30
  31 (defclass ginterface ()
  32   ())
  33
  34 ;;;; Metaclass for interfaces
  35
  36 (eval-when (:compile-toplevel :load-toplevel :execute)
  37   (defclass ginterface-class (virtual-slots-class)
  38     ()))
  39
  40 (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
  41   (case (getf initargs :allocation)
  42     (:property (find-class 'direct-property-slot-definition))
  43     (t (call-next-method))))
  44
  45 (defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
  46   (case (getf initargs :allocation)
  47     (:property (find-class 'effective-property-slot-definition))
  48     (t (call-next-method))))
  49
  50 (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds)
  51   (if (eq (slot-definition-allocation (first direct-slotds)) :property)
  52       (nconc
  53        (list :pname (signal-name-to-string
  54                      (most-specific-slot-value direct-slotds 'pname))
  55              :readable (most-specific-slot-value direct-slotds 'readable)
  56              :writable (most-specific-slot-value direct-slotds 'writable)
  57              :construct-only (most-specific-slot-value direct-slotds 'construct))
  58        (call-next-method))
  59     (call-next-method)))
  60
  61
  62 (defmethod shared-initialize ((class ginterface-class) names &key name gtype)
  63   (declare (ignore names))
  64   (let* ((class-name (or name (class-name class)))
  65          (type-number
  66           (or
  67            (find-type-number class-name)
  68            (register-type class-name
  69             (or (first gtype) (default-type-init-name class-name))))))
  70     (type-default-interface-ref type-number))
  71   (call-next-method))
  72
  73
  74 (defmethod validate-superclass ((class ginterface-class) (super standard-class))
  75   (subtypep (class-name super) 'ginterface))
  76
  77
  78 (define-type-method alien-type ((type ginterface))
  79   (declare (ignore type))
  80   (alien-type 'gobject))
  81
  82 (define-type-method size-of ((type ginterface))
  83   (declare (ignore type))
  84   (size-of 'gobject))
  85
  86 (define-type-method from-alien-form ((type ginterface) location)
  87   (declare (ignore type))
  88   (from-alien-form 'gobject location))
  89
  90 (define-type-method from-alien-function ((type ginterface))
  91   (declare (ignore type))
  92   (from-alien-function 'gobject))
  93
  94 (define-type-method to-alien-form ((type ginterface) instance)
  95   (declare (ignore type))
  96   (to-alien-form 'gobject instance))
  97
  98 (define-type-method to-alien-function ((type ginterface))
  99   (declare (ignore type))
 100   (to-alien-function 'gobject))
 101
 102 (define-type-method reader-function ((type ginterface))
 103   (declare (ignore type))
 104   (reader-function 'gobject))
 105
 106 (define-type-method writer-function ((type ginterface))
 107   (declare (ignore type))
 108   (writer-function 'gobject))
 109
 110 (define-type-method destroy-function ((type ginterface))
 111   (declare (ignore type))
 112   (destroy-function 'gobject))
 113
 114
 115 ;;;;
 116
 117
 118 (defbinding type-default-interface-ref (type) pointer
 119   ((find-type-number type t) type-number))
 120
 121 (defbinding type-default-interface-unref () nil
 122   (iface pointer))
 123
 124 (defbinding type-default-interface-peek (type) pointer
 125   ((find-type-number type t) type-number))
 126
 127 (defbinding %object-interface-list-properties () pointer
 128   (iface pointer)
 129   (n-properties unsigned-int :out))
 130
 131 (defun query-object-interface-properties (type &optional inherited-p)
 132   (let* ((type-number (find-type-number type))
 133          (iface (type-default-interface-ref type-number)))
 134     (unwind-protect
 135          (multiple-value-bind (array length)
 136              (%object-interface-list-properties iface)
 137            (unless (null-pointer-p array)
 138              (unwind-protect
 139                  (%map-params array length type-number inherited-p)
 140                (deallocate-memory array))))
 141       (type-default-interface-unref iface))))
 142
 143
 144 (defun expand-ginterface-type (type forward-p options &rest args)
 145   (declare (ignore args))
 146   (let ((class (type-from-number type))
 147         (slots (getf options :slots)))
 148     `(defclass ,class (,(supertype type))
 149        ,(unless forward-p
 150           (slot-definitions class (query-object-interface-properties type) slots))
 151       (:metaclass ginterface-class)
 152       (:gtype ,(register-type-as type)))))
 153
 154 (defun ginterface-dependencies (type)
 155   (delete-duplicates
 156    (cons
 157     (supertype type)
 158     (mapcar #'param-value-type (query-object-interface-properties type)))))
 159
 160 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)