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