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.12 2005-04-23 16:48:50 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 (most-specific-slot-value direct-slotds 'allocation) :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 (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     )
  72   (call-next-method))
  73
  74
  75 (defmethod validate-superclass ((class ginterface-class) (super standard-class))
  76   (subtypep (class-name super) 'ginterface))
  77
  78
  79 (defmethod alien-type ((class ginterface-class) &rest args)
  80   (declare (ignore class args))
  81   (alien-type 'gobject))
  82
  83 (defmethod size-of ((class ginterface-class) &rest args)
  84   (declare (ignore class args))
  85   (size-of 'gobject))
  86
  87 (defmethod from-alien-form (location (class ginterface-class) &rest args)
  88   (declare (ignore class args))
  89   (from-alien-form location 'gobject))
  90
  91 (defmethod from-alien-function ((class ginterface-class) &rest args)
  92   (declare (ignore class args))
  93   (from-alien-function 'gobject))
  94
  95 (defmethod to-alien-form (instance (class ginterface-class) &rest args)
  96   (declare (ignore class args))
  97   (to-alien-form instance 'gobject))
  98
  99 (defmethod to-alien-function ((class ginterface-class) &rest args)
 100   (declare (ignore class args))
 101   (to-alien-function 'gobject))
 102
 103 (defmethod reader-function ((class ginterface-class) &rest args)
 104   (declare (ignore class args))
 105   (reader-function 'gobject))
 106
 107 (defmethod writer-function ((class ginterface-class) &rest args)
 108   (declare (ignore class args))
 109   (writer-function 'gobject))
 110
 111 (defmethod destroy-function ((class ginterface-class) &rest args)
 112   (declare (ignore class args))
 113   (destroy-function 'gobject))
 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 (type) nil
 123   ((find-type-number type t) type-number))
 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 type-number)
 143       )))
 144
 145
 146 (defun expand-ginterface-type (type forward-p options &rest args)
 147   (declare (ignore args))
 148   (let ((class (type-from-number type))
 149         (slots (getf options :slots)))
 150     `(defclass ,class (,(supertype type))
 151        ,(unless forward-p
 152           (slot-definitions class (query-object-interface-properties type) slots))
 153       (:metaclass ginterface-class)
 154       (:gtype ,(register-type-as type)))))
 155
 156 (defun ginterface-dependencies (type)
 157   (delete-duplicates
 158    (cons
 159     (supertype type)
 160     (mapcar #'param-value-type (query-object-interface-properties type)))))
 161
 162 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)