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